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 00000001361 10421100140 012215 0 ustar bulant bulant #!perl #
# # Perl script 'append.pl' to append the file specified by the second # command-line argument to the file specified by the first command-line # argument. It does not work correctly with binary data under MS DOS. # # Syntax: # append.pl "file1" "file2" # File "file2" will be appended to the file "file1". # # ====================================================================== # Main program 'append.pl': # ~~~~~~~~~~~~~~~~~~~~~~~~~ $FILE1=$ARGV[0]; $FILE2=$ARGV[1]; @ARGV=(); require 'go.pl'; &APPEND($FILE1,$FILE2); # ====================================================================== 1; #ascbin.for 0100666 0000765 0000765 00000015233 11023416420 012375 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 00000031160 11023416420 012372 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. 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 00000071030 11023416420 012551 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 00000064453 11023416420 012572 0 ustar bulant bulant C
C CalComp-PostScript interface C C Version: 6.00 C Date: 2006, April 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 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 C Optional input SEP parameter: C CALCOPS='string'... String with the PostScript instructions C to be written to the end of 'Setup' section of the C output PostScript file. C Default: CALCOPS=' ' C Example: CALCOPS='0.5 setlinewidth' 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: 2005, May 11 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 CHARACTER*255 TEXTPS 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 Reading input SEP parameter CALCOPS: CALL RSEP3T('CALCOPS',TEXTPS,' ') 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' *,TEXTPS *,'%%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) NOUTS=0 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 CHARACTER*100 TEXT 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 Subroutines and external functions required. EXTERNAL LENGTH INTEGER LENGTH C C Date: 2006, April 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: REAL X,Y,XO,YO,XPAG,YPAG C C....................................................................... C XPAG=XPAGE YPAG=YPAGE X=SCALE*(STARTX+XPAG) Y=SCALE*(STARTY+YPAG) IF((X.LE.-9999.45).OR.(X.GE.99999.45).OR. * (Y.LE.-9999.45).OR.(Y.GE.99999.45)) THEN IF(X.LE.-9999.45) X=-9999.45 IF(X.GE.99999.45) X=99999.45 IF(Y.LE.-9999.45) Y=-9999.45 IF(Y.GE.99999.45) Y=99999.45 XPAG=X/SCALE-STARTX YPAG=Y/SCALE-STARTY NOUTS=NOUTS+1 END IF C Plotting the line: IF(IABS(IPEN).EQ.2) THEN 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 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=XPAG YOLD=YPAG ELSE STARTX=STARTX+XPAG STARTY=STARTY+YPAG 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) IF(NOUTS.GT.0) THEN IF(NOUTS.LE.999999) THEN WRITE(TEXT,'(A,I6)') * 'CALCOPS-04: Number of points outside plotting area: ',NOUTS ELSE WRITE(TEXT,'(A)') * 'CALCOPS-04: More than 999999 points outside plotting area' END IF C CALCOPS-04 CALL WARN(TEXT(1:LENGTH(TEXT))) C Point which was outside plotting area has been moved to the C boundary of the plotting area, picture may be distorted. C Plotting area ranges from -9999.45 pt to 99999.45 pt both C in X and Y, i.e. from -352.7 cm to 3527 cm. END IF 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: 2006, March 16 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((SX.LE.-9999.45).OR.(SX.GE.99999.45).OR. * (SY.LE.-9999.45).OR.(SY.GE.99999.45)) THEN IF(SX.LE.-9999.45) SX=-9999.45 IF(SX.GE.99999.45) SX=99999.45 IF(SY.LE.-9999.45) SY=-9999.45 IF(SY.GE.99999.45) SY=99999.45 X=SX/SCALE-STARTX Y=SY/SCALE-STARTY NOUTS=NOUTS+1 END IF 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: 2006, March 16 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((X.LE.-9999.45).OR.(X.GE.99999.45).OR. * (Y.LE.-9999.45).OR.(Y.GE.99999.45)) THEN IF(X.LE.-9999.45) X=-9999.45 IF(X.GE.99999.45) X=99999.45 IF(Y.LE.-9999.45) Y=-9999.45 IF(Y.GE.99999.45) Y=99999.45 NOUTS=NOUTS+1 END IF 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 00000003405 10406177340 012554 0 ustar bulant bulant C
C INCLUDE 'calcops.inc' C ------------------------------------------------------------------ INTEGER LUCFG,MCOLOR,KOLOR,NOUTS 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 * ,NOUTS 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 NOUTS...Number of points which were originally outside C the plotting area. C C Common block /PLOTC/ is included in FORTRAN 77 source code file C 'calcops.for'. C C Date: 2006, March 16 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 00000001313 11023416420 011522 0 ustar bulant bulant #!perl #
# # Perl script 'chk.pl' to check input data files required by history # files. # # For the description refer to the subroutine # CHK # of file 'go.pl'. # # Version: 6.10 # Date: 2006, October 9 # ====================================================================== # Main program 'chk.pl': # ~~~~~~~~~~~~~~~~~~~~~~ $PATH=$ARGV[0]; $FILE=$ARGV[1]; if ($FILE ne '') { @ARGV=(); require 'go.pl'; &CHK($PATH,$FILE); } # ====================================================================== 1; #coef52.for 0100666 0000765 0000765 00000133123 11023416420 012220 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 00000030614 11023416420 012437 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 C 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; #cremove.for 0100666 0000765 0000765 00000006501 11023416420 012574 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 do-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 00000012413 10444173560 012235 0 ustar bulant bulant C
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======================================================================= Ceigennr.for 0100666 0000765 0000765 00000010130 11023416420 012554 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 C tred2.for of Numerical Recipes. C TQLI ... File C tqli.for of Numerical Recipes. C INDEXX ... File C indexx.for of Numerical Recipes. 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 00000004151 11021432020 012244 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('gse2segy',@OPTIONS); &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('sgfhom' ,@OPTIONS); &COMPILE('sgfgrd' ,@OPTIONS); &COMPILE('sgfmat' ,@OPTIONS); &COMPILE('mgrd' ,@OPTIONS); &COMPILE('grdpts' ,@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('grdgse' ,@OPTIONS); &COMPILE('grdran2d',@OPTIONS); &COMPILE('grdran' ,@OPTIONS); &COMPILE('grdcor' ,@OPTIONS); &COMPILE('grdstat' ,@OPTIONS); &COMPILE('grdckn' ,@OPTIONS); &COMPILE('grdcros' ,@OPTIONS); &COMPILE('grdte' ,@OPTIONS); &COMPILE('binasc' ,@OPTIONS); &COMPILE('ascbin' ,@OPTIONS); &COMPILE('swap' ,@OPTIONS); &COMPILE('ptsgrd' ,@OPTIONS); &COMPILE('grdps' ,@OPTIONS); &COMPILE('matmul' ,@OPTIONS); &COMPILE('matlin' ,@OPTIONS); &COMPILE('matfun' ,@OPTIONS); &COMPILE('matinv' ,@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 00000073612 11024140020 012773 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: 6.20 C Date: 2008, January 18 C C Coded by: Ludek Klimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C This file consists of the following external procedures: C UARRAY..Function returning the undefined value used in the C unformatted files with real arrays. C UARRAY C WARRAY..Subroutine designed to write a given real array into the C given formatted or unformatted file. C WARRAY C WARRAI..Subroutine designed to write a given integer array into C the given formatted or unformatted file. C WARRAI C RARRAY..Subroutine designed to read the real array from the given C formatted or unformatted file. C RARRAY C RARRAI..Subroutine designed to read the integer array from the C given formatted or unformatted file. C RARRAI C WARAY...Subroutine calling WARRAY for N4 individual time levels. C WARAY C WARAI...Subroutine calling WARRAI for N4 individual time levels. C WARAI C RARAY...Subroutine calling RARRAY for N4 individual time levels. C RARAY C RARAI...Subroutine calling RARRAI for N4 individual time levels. C RARAI C FORM1...Subroutine designed to determine the best output format C for reals. C FORM1 C FORM2...Subroutine designed to determine the best output format C for multiples of real numbers. C FORM2 C C======================================================================= C C C REAL FUNCTION UARRAY() C C Function returning the undefined value used in the unformatted files C with real-valued arrays. C C No input. C C Output: C UARRAY..The value used as "undefined value" in the unformatted C files with real-valued arrays by subroutines WARRAY and C RARRAY. C C Date: 2005, June 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: REAL UNDEF PARAMETER (UNDEF=-3.4E+38) C UARRAY=UNDEF RETURN END C C======================================================================= C C C SUBROUTINE WARRAY(LU,FILE,FORM,LMIN,VMIN,LMAX,VMAX,NOUT,OUT) CHARACTER*(*) FILE,FORM LOGICAL LMIN,LMAX INTEGER LU,NOUT REAL VMIN,VMAX,OUT(NOUT) C C Subroutine designed to write a given real array into the file. C C Input: C LU... Logical unit number to be used for the output. C FILE... Destination filename. If not blank, the file will be C opened and closed. If blank, the file is assumed to be C already open, and will not be closed in this subroutine. C FORM... Form of the output file: either 'FORMATTED' or C 'UNFORMATTED'. C LMIN... TRUE if the null values are to be written in place of C array elements less than or equal to VMIN, otherwise C FALSE. C Formatted output: C The null values are treated as default values when read C by list-directed input (free format). C Example: 124 null values are written as ' 124*'. C Unformatted output: C The values of -999999999 are written in place of the C null values. C VMIN... Trade-off limit. C LMAX... TRUE if the null values are to be written in place of C array elements greater than or equal to VMAX, otherwise C FALSE. C VMAX... Trade-off limit. C NOUT... Dimension of the array OUT. C OUT... Array to be written. C C No output. C C C Input SEP parameter: C NUMLIN=positive integer... Number of the numbers to be written C to each line of the output file. C NUMLIN must be less than 100 (99 at most). C Default: NUMLIN=10 C C Date: 2007, January 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: EXTERNAL UARRAY REAL UARRAY REAL UNDEF C C Local storage locations: CHARACTER*11 FORML CHARACTER*14 FORMAT INTEGER IMIN,IADR REAL OUTMIN,OUTMAX,VMINA,VMAXA C FORMAT..String containing the output format, e.g. like (10F8.3). C IMIN... Loop lower bound, locally also loop variable. C IADR... Loop variable. C OUTMIN,OUTMAX... Minimum and maximum defined element to determine C the best format for printing. C VMINA,VMAXA... Local storage locations for VMIN, VMAX. C INTEGER NUMLIN SAVE NUMLIN DATA NUMLIN/-1/ C C....................................................................... C UNDEF=UARRAY() C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM) END IF C C Formatted or unformatted output: FORML=FORM CALL LOWER(FORML) IF(FORML.EQ.'formatted') THEN C C Minimum and maximum elements: OUTMIN=0. IF(LMIN) THEN VMINA=VMIN DO 11 IADR=1,NOUT IF(OUTMIN.GT.OUT(IADR)) THEN IF(OUT(IADR).GT.VMINA) THEN OUTMIN=OUT(IADR) END IF END IF 11 CONTINUE ELSE DO 12 IADR=1,NOUT IF(OUTMIN.GT.OUT(IADR)) THEN OUTMIN=OUT(IADR) END IF 12 CONTINUE END IF OUTMAX=0. IF(LMAX) THEN VMAXA=VMAX DO 13 IADR=1,NOUT IF(OUTMAX.LT.OUT(IADR)) THEN IF(OUT(IADR).LT.VMAXA) THEN OUTMAX=OUT(IADR) END IF END IF 13 CONTINUE ELSE DO 14 IADR=1,NOUT IF(OUTMAX.LT.OUT(IADR)) THEN OUTMAX=OUT(IADR) END IF 14 CONTINUE END IF C C Setting output format for the array: IF (NUMLIN.EQ.-1) THEN CALL RSEP3I('NUMLIN',NUMLIN,10) ENDIF FORMAT='(00(F00.0,1X))' FORMAT(3:3)=CHAR(ICHAR('0')+MOD(NUMLIN,10)) FORMAT(2:2)=CHAR(ICHAR('0')+ NUMLIN/10 ) CALL FORM1(OUTMIN,OUTMAX,FORMAT(5:12)) FORMAT(11:14)= '1X))' C Output format is set. C C Printing loop: C Initial value of the first element to print IADR=1 C Beginning of the loop 20 CONTINUE C C Trade off (searching for undefined elements): IMIN=IADR IF(LMIN) THEN IF(LMAX) THEN DO 21 IADR=IMIN,NOUT IF(OUT(IADR).LE.VMINA.OR.OUT(IADR).GE.VMAXA) THEN GO TO 29 END IF 21 CONTINUE ELSE DO 22 IADR=IMIN,NOUT IF(OUT(IADR).LE.VMINA) THEN GO TO 29 END IF 22 CONTINUE END IF ELSE IF(LMAX) THEN DO 23 IADR=IMIN,NOUT IF(OUT(IADR).GE.VMAXA) THEN GO TO 29 END IF 23 CONTINUE ELSE IADR=NOUT+1 END IF END IF 29 CONTINUE C IADR is the first undefined element. C C Writing the array (defined elements): IF(IMIN.EQ.1.AND.IADR.GT.NOUT) THEN WRITE(LU,FORMAT) OUT GO TO 90 ELSE WRITE(LU,FORMAT) (OUT(IMIN),IMIN=IMIN,IADR-1) IF(IADR.GT.NOUT) THEN GO TO 90 END IF END IF C C Searching for the next defined elements: IMIN=IADR IF(LMIN) THEN IF(LMAX) THEN DO 31 IADR=IADR,NOUT IF(OUT(IADR).GT.VMINA.AND.OUT(IADR).LT.VMAXA) THEN GO TO 39 END IF 31 CONTINUE ELSE DO 32 IADR=IADR,NOUT IF(OUT(IADR).GT.VMINA) THEN GO TO 39 END IF 32 CONTINUE END IF ELSE IF(LMAX) THEN DO 33 IADR=IADR,NOUT IF(OUT(IADR).LT.VMAXA) THEN GO TO 39 END IF 33 CONTINUE ELSE IADR=NOUT+1 END IF END IF 39 CONTINUE C IADR is the first defined element. C C Writing the array (undefined elements): WRITE(LU,'(I7,A)') IADR-IMIN,'*' IF(NOUT.LT.IADR) THEN GO TO 90 END IF C GO TO 20 ELSE C C Null values: IF(LMIN) THEN VMINA=VMIN IF(LMAX) THEN VMAXA=VMAX DO 51 IADR=1,NOUT IF(OUT(IADR).LE.VMINA.OR.VMAXA.LE.OUT(IADR)) THEN OUT(IADR)=UNDEF END IF 51 CONTINUE ELSE DO 52 IADR=1,NOUT IF(OUT(IADR).LE.VMINA) THEN OUT(IADR)=UNDEF END IF 52 CONTINUE END IF ELSE IF(LMAX) THEN VMAXA=VMAX DO 53 IADR=1,NOUT IF(VMAXA.LE.OUT(IADR)) THEN OUT(IADR)=UNDEF END IF 53 CONTINUE END IF END IF C C Writing the array: WRITE(LU) OUT C END IF 90 CONTINUE IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE WARRAI(LU,FILE,FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT,IOUT) CHARACTER*(*) FILE,FORM LOGICAL LMIN,LMAX INTEGER LU,NOUT,IVMIN,IVMAX,IOUT(NOUT) C C Subroutine designed to write a given integer array into the file. C C Input: C LU... Logical unit number to be used for the output. C FILE... Destination filename. If not blank, the file will be C opened and closed. If blank, the file is assumed to be C already open, and will not be closed in this subroutine. C FORM... Form of the output file: either 'FORMATTED' or C 'UNFORMATTED'. C LMIN... TRUE if the null values are to be written in place of C array elements less than or equal to IVMIN, otherwise C FALSE. C Formatted output: C The null values are treated as default values when read C by list-directed input (free format). C Example: 124 null values are written as ' 124*'. C Unformatted output: C The values of -999999999 are written in place of the C null values. C IVMIN . Trade-off limit. C LMAX... TRUE if the null values are to be written in place of C array elements greater than or equal to IVMAX, otherwise C FALSE. C IVMAX...Trade-off limit. C NOUT... Dimension of the array IOUT. C IOUT... Array to be written. C C No output. C C Input SEP parameter: C NUMLIN=positive integer... Number of the numbers to be written C to each line of the output file. C NUMLIN must be less than 100 (99 at most). C Default: NUMLIN=10 C C Date: 2007, January 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: INTEGER IUNDEF PARAMETER (IUNDEF=-999999999) C C Local storage locations: CHARACTER*11 FORML CHARACTER*12 FORMAT INTEGER IMIN,IADR,MINOUT,MAXOUT,IVMINA,IVMAXA C FORMAT..String containing the output format, e.g. like (10I08). C IMIN... Loop lower bound, locally also loop variable. C IADR... Loop variable. C MINOUT,MAXOUT... Minimum and maximum defined element to determine C the best format for printing. C IVMINA,IVMAXA... Local storage locations for IVMIN, IVMAX. C INTEGER NUMLIN SAVE NUMLIN DATA NUMLIN/-1/ C C....................................................................... C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM) END IF C C Formatted or unformatted output: FORML=FORM CALL LOWER(FORML) IF(FORML.EQ.'formatted') THEN C C Minimum and maximum elements: MINOUT=0 IF(LMIN) THEN IVMINA=IVMIN DO 11 IADR=1,NOUT IF(MINOUT.GT.IOUT(IADR)) THEN IF(IOUT(IADR).GT.IVMINA) THEN MINOUT=IOUT(IADR) END IF END IF 11 CONTINUE ELSE DO 12 IADR=1,NOUT IF(MINOUT.GT.IOUT(IADR)) THEN MINOUT=IOUT(IADR) END IF 12 CONTINUE END IF MAXOUT=0 IF(LMAX) THEN IVMAXA=IVMAX DO 13 IADR=1,NOUT IF(MAXOUT.LT.IOUT(IADR)) THEN IF(IOUT(IADR).LT.IVMAXA) THEN MAXOUT=IOUT(IADR) END IF END IF 13 CONTINUE ELSE DO 14 IADR=1,NOUT IF(MAXOUT.LT.IOUT(IADR)) THEN MAXOUT=IOUT(IADR) END IF 14 CONTINUE END IF C C Setting output format for the array: IF (NUMLIN.EQ.-1) THEN CALL RSEP3I('NUMLIN',NUMLIN,10) ENDIF FORMAT='(00(I00,1X))' FORMAT(3:3)=CHAR(ICHAR('0')+MOD(NUMLIN,10)) FORMAT(2:2)=CHAR(ICHAR('0')+ NUMLIN/10 ) IMIN=MAXOUT IF(MINOUT.LT.0.) THEN IMIN=MAX0(IMIN,-10*MINOUT) END IF DO 15 IADR=1,99 IMIN=IMIN/10 IF(IMIN.LT.1) THEN FORMAT(6:6)=CHAR(ICHAR('0')+IADR/10) FORMAT(7:7)=CHAR(ICHAR('0')+MOD(IADR,10)) GO TO 16 END IF 15 CONTINUE 16 CONTINUE C Output format is set. C C Printing loop: C Initial value of the first element to print IADR=1 C Beginning of the loop 20 CONTINUE C C Trade off (searching for undefined elements): IMIN=IADR IF(LMIN) THEN IF(LMAX) THEN DO 21 IADR=IMIN,NOUT IF(IOUT(IADR).LE.IVMINA.OR.IOUT(IADR).GE.IVMAXA) THEN GO TO 29 END IF 21 CONTINUE ELSE DO 22 IADR=IMIN,NOUT IF(IOUT(IADR).LE.IVMINA) THEN GO TO 29 END IF 22 CONTINUE END IF ELSE IF(LMAX) THEN DO 23 IADR=IMIN,NOUT IF(IOUT(IADR).GE.IVMAXA) THEN GO TO 29 END IF 23 CONTINUE ELSE IADR=NOUT+1 END IF END IF 29 CONTINUE C IADR is the first undefined element. C C Writing the array (defined elements): IF(IMIN.EQ.1.AND.IADR.GT.NOUT) THEN WRITE(LU,FORMAT) IOUT GO TO 90 ELSE WRITE(LU,FORMAT) (IOUT(IMIN),IMIN=IMIN,IADR-1) IF(IADR.GT.NOUT) THEN GO TO 90 END IF END IF C C Searching for the next defined elements: IMIN=IADR IF(LMIN) THEN IF(LMAX) THEN DO 31 IADR=IADR,NOUT IF(IOUT(IADR).GT.IVMINA.AND.IOUT(IADR).LT.IVMAXA) THEN GO TO 39 END IF 31 CONTINUE ELSE DO 32 IADR=IADR,NOUT IF(IOUT(IADR).GT.IVMINA) THEN GO TO 39 END IF 32 CONTINUE END IF ELSE IF(LMAX) THEN DO 33 IADR=IADR,NOUT IF(IOUT(IADR).LT.IVMAXA) THEN GO TO 39 END IF 33 CONTINUE ELSE IADR=NOUT+1 END IF END IF 39 CONTINUE C IADR is the first defined element. C C Writing the array (undefined elements): WRITE(LU,'(I7,A)') IADR-IMIN,'*' IF(NOUT.LT.IADR) THEN GO TO 90 END IF C GO TO 20 ELSE C C Null values: IF(LMIN) THEN IVMINA=IVMIN IF(LMAX) THEN IVMAXA=IVMAX DO 51 IADR=1,NOUT IF(IOUT(IADR).LE.IVMINA.OR.IVMAXA.LE.IOUT(IADR)) THEN IOUT(IADR)=IUNDEF END IF 51 CONTINUE ELSE DO 52 IADR=1,NOUT IF(IOUT(IADR).LE.IVMINA) THEN IOUT(IADR)=IUNDEF END IF 52 CONTINUE END IF ELSE IF(LMAX) THEN IVMAXA=IVMAX DO 53 IADR=1,NOUT IF(IVMAXA.LE.IOUT(IADR)) THEN IOUT(IADR)=IUNDEF END IF 53 CONTINUE END IF END IF C C Writing the array: WRITE(LU) IOUT C END IF 90 CONTINUE IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RARRAY(LU,FILE,FORM,LDEF,DEF,N,ARRAY) CHARACTER*(*) FILE,FORM LOGICAL LDEF INTEGER LU,N REAL DEF,ARRAY(N) C C Subroutine designed to read the real array from the disk. C C Input: C LU... Logical unit number to be used. C FILE... Source filename. If not blank, the file will be C opened and closed. If blank, the file is assumed to be C already open, and will not be closed in this subroutine. C FORM... Form of the output file: either 'FORMATTED' or C 'UNFORMATTED'. C LDEF... True if the null values are to be replaced by the given C default value DEF. C If FORM='FORMATTED' and LDEF=.FALSE., the array elements C corresponding to null values remain unchanged. C DEF... Default value. C N... Array dimension (number of elements to read). C C Output: C ARRAY.. Array having been read. C C Date: 2000, November 25 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: EXTERNAL UARRAY REAL UARRAY REAL UNDEF C CHARACTER*11 FORML INTEGER I REAL AUX C UNDEF=UARRAY() C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM,STATUS='OLD') END IF C FORML=FORM CALL LOWER(FORML) IF(FORML.EQ.'formatted') THEN IF(LDEF) THEN AUX=DEF DO 10 I=1,N ARRAY(I)=AUX 10 CONTINUE END IF READ(LU,*) ARRAY ELSE READ(LU) ARRAY IF(LDEF) THEN IF(DEF.NE.UNDEF) THEN AUX=DEF DO 20 I=1,N IF(ARRAY(I).EQ.UNDEF) THEN ARRAY(I)=AUX END IF 20 CONTINUE END IF END IF END IF C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RARRAI(LU,FILE,FORM,LDEF,IDEF,N,IARRAY) CHARACTER*(*) FILE,FORM LOGICAL LDEF INTEGER LU,IDEF,N,IARRAY(N) C C Subroutine designed to read the integer array from the disk. C C Input: C LU... Logical unit number to be used. C FILE... Source filename. If not blank, the file will be C opened and closed. If blank, the file is assumed to be C already open, and will not be closed in this subroutine. C FORM... Form of the output file: either 'FORMATTED' or C 'UNFORMATTED'. C LDEF... True if the null values are to be replaced by the given C default value IDEF. C If FORM='FORMATTED' and LDEF=.FALSE., the array elements C corresponding to null values remain unchanged. C IDEF... Default value. C N... Array dimension (number of elements to read). C C Output: C IARRAY..Array having been read. C C Date: 2000, November 25 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Parameters: INTEGER IUNDEF PARAMETER (IUNDEF=-999999999) C CHARACTER*11 FORML INTEGER I,IAUX C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM,STATUS='OLD') END IF C FORML=FORM CALL LOWER(FORML) IF(FORML.EQ.'formatted') THEN IF(LDEF) THEN IAUX=IDEF DO 10 I=1,N IARRAY(I)=IAUX 10 CONTINUE END IF READ(LU,*) IARRAY ELSE READ(LU) IARRAY IF(LDEF) THEN C IF(IDEF.NE.IUNDEF) THEN IAUX=IDEF DO 20 I=1,N IF(IARRAY(I).EQ.IUNDEF) THEN IARRAY(I)=IAUX END IF 20 CONTINUE C END IF END IF END IF C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE WARAY(LU,FILE,FORM,LMIN,VMIN,LMAX,VMAX,NOUT,N4,OUT) CHARACTER*(*) FILE,FORM LOGICAL LMIN,LMAX INTEGER LU,NOUT,N4 REAL VMIN,VMAX,OUT(NOUT,N4) C C Subroutine designed to N4 times call subroutine WARRAY, for individual C time levels. C C Input: C LU,FILE,FORM,LMIN,VMIN,LMAX,VMAX,NOUT... Refer to subroutine C WARRAY C N4... Number of time levels. NOUT values corresponding to each C level are written through an individual invocation of C subroutine WARRAY. C OUT... Array of dimension NOUT*N4 to be written. C C No output. C C Date: 1998, March 21 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 C C....................................................................... C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM) END IF C DO 10 I4=1,N4 CALL WARRAY(LU,' ',FORM,LMIN,VMIN,LMAX,VMAX,NOUT,OUT(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE WARAI(LU,FILE,FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT,N4,IOUT) CHARACTER*(*) FILE,FORM LOGICAL LMIN,LMAX INTEGER LU,IVMIN,IVMAX,NOUT,N4,IOUT(NOUT,N4) C C Subroutine designed to N4 times call subroutine WARRAI, for individual C time levels. C C Input: C LU,FILE,FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT... Refer to subroutine C WARRAI C N4... Number of time levels. NOUT values corresponding to each C level are written through an individual invocation of C subroutine WARRAI. C IOUT... Array of dimension NOUT*N4 to be written. C C No output. C C Date: 1998, May 28 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 C C....................................................................... C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Writing: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM) END IF C DO 10 I4=1,N4 CALL WARRAI(LU,' ',FORM,LMIN,IVMIN,LMAX,IVMAX,NOUT,IOUT(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RARAY(LU,FILE,FORM,LDEF,DEF,N,N4,ARRAY) CHARACTER*(*) FILE,FORM LOGICAL LDEF INTEGER LU,N,N4 REAL DEF,ARRAY(N,N4) C C Subroutine designed to N4 times call subroutine RARRAY, for individual C time levels. C C Input: C LU,FILE,FORM,LDEF,DEF,N... Refer to subroutine C RARRAY C N4... Number of time levels. N values corresponding to each C level are read by an individual invocation of subroutine C RARRAY. C C Output: C ARRAY...Array of dimension N*N4 having been read. C C Date: 2000, July 31 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 C C....................................................................... C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM,STATUS='OLD') END IF C DO 10 I4=1,N4 CALL RARRAY(LU,' ',FORM,LDEF,DEF,N,ARRAY(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE RARAI(LU,FILE,FORM,LDEF,IDEF,N,N4,IARRAY) CHARACTER*(*) FILE,FORM LOGICAL LDEF INTEGER LU,N,IDEF,N4,IARRAY(N,N4) C C Subroutine designed to N4 times call subroutine RARRAI, for individual C time levels. C C Input: C LU,FILE,FORM,LDEF,IDEF,N,N4... Refer to subroutine C RARRAI C C Output: C IARRAY..Array of dimension N*N4 having been read. C C Date: 2000, July 31 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I4 C C....................................................................... C IF(FILE.NE.' ') THEN WRITE(*,'(''+'',79('' ''))') WRITE(*,'(2A)') '+Reading: ',FILE(1:MIN0(LEN(FILE),70)) OPEN(LU,FILE=FILE,FORM=FORM,STATUS='OLD') END IF C DO 10 I4=1,N4 CALL RARRAI(LU,' ',FORM,LDEF,IDEF,N,IARRAY(1,I4)) 10 CONTINUE C IF(FILE.NE.' ') THEN CLOSE(LU) END IF RETURN END C C======================================================================= C C C SUBROUTINE FORM1(OUTMIN,OUTMAX,FORMAT) REAL OUTMIN,OUTMAX CHARACTER*8 FORMAT C C Subroutine designed to determine the best output format for reals. C C Input: C OUTMIN,OUTMAX... Minimum and maximum real number to be written. C C Output: C FORMAT..String containing the output format e.g. like 'F07.3,A,'. C The width of the defined string is 8 characters. C It has the form of 'F00.0,A,', where zeros are replaced C by reasonable values. The subroutine outputs C at least MAXDIG digits (including all zeros after the C decimal point) of the largest positive number OUTMAX or C MAXDIG-1 digits of the most negative number if OUTMIN is C negative, and adjusts the width of the output field to C MAXDIG+1 columns, if possible. The (MAXDIG+2)th column is C reserved for a space or another separator. C If OUTMIN=0 and OUTMAX=0, the width of the output field is C adjusted to 2 columns. C If the number of digits (without leading zeros) is smaller C than MINDIG, format Fnn.d with nn=MAXDIG+1 is changed to C Gmm.d with mm=MAXDIG+5. The (MAXDIG+6)th column is C reserved for a space or another separator. C C Input SEP parameters: C MAXDIG=positive integer... Minimum number of digits of the largest C positive number OUTMAX in the output format, C see the description of FORMAT above. C MAXDIG must be less than 10. C Default: MAXDIG=6 C MINDIG=positive integer... Number of digits to change edition F C to edition G, see the description of FORMAT above. C MINDIG should be less than MAXDIG. C Default: MINDIG=4 C C Date: 2008, January 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER MAXDIG,MINDIG INTEGER IFORM1,IFORM2 REAL SMALL SAVE MAXDIG,MINDIG DATA MAXDIG/-1/ C IFORM1,IFORM2... Define format to write the travel times. C Limits: 0.LE.IFORM2.LE.9, IFORM2+1.LE.IFORM1.LE.99. C C....................................................................... C IF (MAXDIG.EQ.-1) THEN CALL RSEP3I('MAXDIG',MAXDIG,6) CALL RSEP3I('MINDIG',MINDIG,4) ENDIF C Setting output format: IFORM1=MAX0(INT(ALOG10(AMAX1(OUTMAX,0.001))+0.3*0.1**MAXDIG+1.),0) IF(OUTMIN.LT.0.) THEN IFORM1=MAX0(INT(ALOG10(AMAX1(-OUTMIN,0.001))+3.0*0.1**MAXDIG+2.) * ,1,IFORM1) END IF C Here, IFORM1 is the number of digits left to the decimal point. IFORM2=MAX0(MAXDIG-IFORM1,0) C IFORM2 is the number of decimal places. IFORM1=IFORM1+IFORM2+1 C IFORM1 is the width of the output field for one element. FORMAT='F02.0,A,' IF(OUTMIN.NE.0..OR.OUTMAX.NE.0.) THEN SMALL=10.**(MINDIG-IFORM2)-0.5*10.**(-IFORM2) IF(-SMALL.LE.OUTMIN.AND.OUTMAX.LE.SMALL) THEN FORMAT='E00.0,A,' IFORM1=MAXDIG+5 IFORM2=MAXDIG IF(OUTMIN.LT.0.) THEN IFORM2=MAXDIG-1 ELSE IFORM2=MAXDIG END IF ELSE IF(IFORM1.GT.MAXDIG+5) THEN FORMAT='E00.0,A,' IFORM1=MAXDIG+5 IF(OUTMIN.LT.0.) THEN IFORM2=MAXDIG-1 ELSE IFORM2=MAXDIG END IF END IF FORMAT(2:2)=CHAR(ICHAR('0')+IFORM1/10) FORMAT(3:3)=CHAR(ICHAR('0')+MOD(IFORM1,10)) FORMAT(5:5)=CHAR(ICHAR('0')+IFORM2) END IF C Output format is set. C RETURN END C C======================================================================= C C C SUBROUTINE FORM2(NQ,OUTMIN,OUTMAX,FORMAT) INTEGER NQ REAL OUTMIN(NQ),OUTMAX(NQ) CHARACTER*(*) FORMAT C C Subroutine designed to determine the best output format for multiples C of real numbers. C C Input: C NQ... Number of reals in each output line. C OUTMIN,OUTMAX... Minimum and maximum real numbers to be written. C FORMAT..String of at least 8*NQ characters. C C Output: C FORMAT..String containing the output format, e.g. like C 'F07.3,A,F07.3,A,F07.3,A,F07.6,A,F07.4,A)'. The width of C the defined string is 8*NQ characters. It has the above C form, where digits are replaced by reasonable values. C Note ')' at the end instead of ','. C The format is set using repeated invocation of subroutine C FORM1, see the description of its C parameters MAXDIG and MINDIG. C C Date: 2005, April 7 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I C C....................................................................... C DO 10 I=1,NQ CALL FORM1(OUTMIN(I),OUTMAX(I),FORMAT(8*I-7:8*I)) 10 CONTINUE FORMAT(8*NQ:8*NQ)=')' C RETURN END C C======================================================================= Cforms.htm 0100666 0000765 0000765 00000130631 11024140020 012255 0 ustar bulant bulant
Package FORMS is designed to facilitate the data exchange between individual programs and to simplify writing, reading, comparing and plotting 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:
All Fortran 77 source code and include files together with all the Perl scripts and data files of package FORMS are assumed to be located in the same single working directory in which the programs will be run.
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.
Path to the root directory of the SW3D software:
There is a possibility to edit file
go.pl
and set path to the root directory of the SW3D software in global
variable $SW3D
to enable full functionality of the Perl
script chk.pl. Some history
files will then be able to copy their input data
from the SW3D-CD disk to the working directory automatically.
# # Function @OUT=RARRAY($FILE) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub RARRAY { $FILE=$_[0]; local(@OUT); open(LU,$FILE); # Reading @OUT=formsver.htm 0100666 0000765 0000765 00000064613 11024140020 013000 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 00000007114 11023416420 012612 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'. 5.90 (2005, June): 'forms.for': New SEP parameters MINDIG and MAXDIG to control formatted writing introduced. The value returned by function UARRAY changed to -3.4E+38. 'length.for': New subroutine STRIND. 'calcops.for','pictures.for','sp.for','ss.for': New SEP parameter CALCOPS for PostScript file setup. 'ptswrl.for','linwrl.for','srfwrl.for','grdwrl.for', 'trglsort.for','trglnorm.for','trglps.for','tsurf.for', 'srp.for','linden.for','grdpts.for','mgrd.for', 'grdtrans.for','grdnew.for','grdmerge.for','grdcal.for', 'grdnorm.for','grdfft.for','grdfd.for','grd2d3d.for', 'grdiso.for','grdran2d.for','grdran.for','grdcor.for', 'grdstat.for','grdte.for','binasc.for','ptsgrd.for': New SEP parameters MINDIG and MAXDIG (without change of dates and versions) enabled. 'tsurf.for': Comments updated. 'ss.for': Ricker signal for source time function added. 'sp.for': The maximum number of input files with seismograms can be adjusted. 'grdcal.for': Undefined value UNDEF is now determined by function UARRAY of file 'forms.for'. 'grdpts.for': New option to write output file with gridpoints in the form of lines. 'grdfft.for': *** Several serious bugs fixed. *** 'f.pl': Comments updated. *** new *** 'gse2segy.for': Program to convert seismograms in GSE format to SEGY format. 'grdgse.for': Program to convert gridded data into GSE format. 'grdmigr.for': Program for common-shot Kirchhoff migration using gridded travel times and amplitudes. 6.00 (2006, June): 'calcops.for','calcops.inc': Plotting area limited according to the format specification used in output writes. 'iniwrl.for','linwrl.for','trglsort.for','trglnorm.for', 'ss.for','sp.for','linden.for','grdpts.for','mgrd.for', 'grdtrans.for','grdnew.for','grdmerge.for','grdnorm.for', 'grdfft.for','grdfd.for','grd2d3d.for','grdiso.for', 'grdgse.for','ptsgrd.for','grdps.for': Undefined value UNDEF is now determined by function UARRAY of file 'forms.for'. 'ptswrl.for': Redundant declarations removed. 'ss.for': Poor declarations improved. Formating of subroutine FCOOLR improved. Description of Ricker signal according to Sheriff added. 'sp.for': Input parameter SPPAR described. *** New possibility to plot travel-time curves. *** 'grdran.for','grdran2d.for': New parameter RANDIS specifying the distribution. 'grdcor.for': New parameter ASOB added. Comments updated. 'cknfft.h','corfft.h','corfun.h': Moved to directory CORFUN of package DATA. 'grdpts.for', 'grdckn.for', 'append.pl','f.pl': Comments updated. *** new *** 'grdcros.for': New program to calculate autocorrelations and crosscorrelations of given grid values. 6.10 (2007, June): 'sep.for': New file opening error message added. 'forms.for': Subroutines OMAT, RMAT and WMAT moved to new file 'mat.for'. 'linwrl.for': Redundant reading of parameter COLORS removed. 'grdckn.for': Calculation of power-law correlation function coded, calculation of Dirac distribution for the case of D/2+N=0 coded. Redundant declaration of RMAT and WMAT as external functions removed. 'binasc.for','grd2d3d.for','grdcal.for','grdcor.for', 'grdcros.for','grdfd.for','grdfft.for','grdmerge.for', 'grdmigr.for','grdnew.for','grdran.for','grdran2d.for', 'grdstat.for','grdte.for','mgrd.for','ptsgrd.for', 'grdnorm.for','grdtrans.for': New SEP parameter NUMLIN (no change in file dates). 'go.pl','chk.pl': Comments updated. *** new *** 'mat.for': New subroutine file for dealing with matrices. 'matmul.for': New program for matrix multiplication. 'matlin.for': New program for calculation of linear combination of two matrices . 'matfun.for': New program to calculate a function of a matrix. 'matinv.for': New program for calculation of inverse matrix. 'sminv.for': Replaced by 'matinv.for'. 'gmt.for','gmgm.for','smgm.for','dmgm.for','smsm.for', 'smsmsm.for','gmdmgmt.for': Replaced by 'matmul.for'. 'grdcal.for','smpower.for','smeigen.for','trsmsm.for': Updated to be compatible with new formats of matrices. 6.20 (2008, June): 'sep.for': Format 'G12.6' changed to 'G13.6'. Declaration of LENGTH improved. 'forms.for': *** Output format 'G', which is erroneous in the Fortran norm, changed to 'E'. *** 'ss.for': Comments updated. 'sp.for','gse2segy.for': SEP parameters read from GSE files moved to separate SEP parameter sets. Comments updated. 'grdte.for': Incorrect usage of the mixed partial derivatives fixed, comments updated. 'mat.for': Description of input and output parameters of all the subroutines improved. 'matmul.for','matlin.for','matinv.for','matfun.for', 'smpower.for','smeigen.for','trsmsm.for': Modified to conform to the new versions of subroutines of file 'mat.for'. Attribute TYPE="..." added into all HTML links to text/html or text/plain files with extension other than .htm (without date or version change). *** new *** 'sep.for': Subroutine SSEP may now determine indices of a new SEP parameter sets. It may also delete the values of already stored SEP parameters. 'length.for': New subroutine UPPER. 'hg.for': New subroutines to calculate some hypergeometric functions. 'sgfhom.for': New program to generate the structural Gabor functions which shape is optimized for a zero-offset surface seismic reflection survey in a homogeneous 2-D velocity model. 'sgfgrd.for': New program to calculate the grid values of a real-valued quantity decomposed into the structural Gabor functions. 'sgfmat.for': New program to generate the system of linear equations for the complex-valued coefficients of the structural Gabor functions in decomposing a given gridded real-valued quantity. 'grdpts.for': Possibility to work with more grids added. 'mat.for': Posibility to read and write sparse matrices in the compressed sparse column format.
f.pl 0100666 0000765 0000765 00000010537 10441736340 011223 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: 6.00 # Date: 2006, June 8 # # 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) # (option -m32 when compiling on 64-bit Linux is recommended) # (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 13000000 to link grdran2d.for) # (use option -stack 100000 to link green.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 00000013042 10444173606 012100 0 ustar bulant bulant C
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======================================================================= Cgksps.for 0100666 0000765 0000765 00000013425 11023416420 012266 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======================================================================= Cgo.pl 0100666 0000765 0000765 00000034604 11023416420 011373 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: 6.10 # Date: 2006, October 9 # # 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 00000013710 11023416420 012365 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. # The subroutine checks the existence of the file '$FILE' in the current # directory. If the file does not exist, the subroutine checks its # existence in the directory '$SW3D$PATH', and, if the file exists # there, the subroutine copies the file to the current directory. # If the file exists neither in the current directory nor in the # '$SW3D$PATH' directory, an error message is generated and the script # is halted. # # Input: # $PATH...String containing the second part of the PATH to desired # file. # $FILE...String containing desired filename. # No output. # # Note: the users are encouraged to change the # $SW3D variable # according to the path to their directory 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: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FSEP,FGRD1,FGRD2 INTEGER LU REAL UNDEF PARAMETER (LU=1) C C Input data: INTEGER N1,N2,N3 REAL O3,D3 C C Other variables: INTEGER I1,I2,I3,I,J REAL X3 C UNDEF=UARRAY() 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 00000123406 11023416420 012374 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: 6.10 C Date: 2007, June 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 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 output files with matrices: C FORMM='string' ... Form of the output files with matrices. Allowed C values are FORMM='formatted' and FORMM='unformatted'. C Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. 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,UARRAY INTEGER LENGTH REAL UARRAY 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) 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 UNDEF=UARRAY() 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 C be increased 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 C be increased 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 INCLUDE 'mat.for' C mat.for INCLUDE 'indexi.for' C indexi.for C C======================================================================= Cgrdckn.for 0100666 0000765 0000765 00000025066 11023416420 012413 0 ustar bulant bulant C
C Program GRDCKN to compute correlation functions C C Version: 6.10 C Date: 2007, June 8 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 The values of the Von Karman correlation function or of the C power-law correlatiopn function are calculated according to the C equations (48) or (66) of the paper: Klimes, L. (2002): Correlation C functions of random media. Pure and Applied Geophysics, 159, C 1811-1831. C C If the value of (NDIM/2+POWERN) equals zero, the Gamma function in C equations (48) or (66) can not be calculated, and the correlation C function becomes to be Dirac distribution realized by the product of C values of (1-|Xi-X0i|/|Di|)/|Di| in the points closer to the point C X0 than one grid interval, and by zeros in other points. C C Otherwise, if the value of ACOR equals to 999999., the power-law C correlation function according to the equation (66) is calculated. C C Otherwise, the Von Karman correlation function according to the C equation (66) is calculated. 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: 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 For infinit ACOR (ACOR=999999.), the power-law C correlation function is calculated. C For other values of ACOR, the Von Karman correlation C function is calculated. C Default: ACOR=999999. (infinity) C CKNMAX=real ... Maximum value of the correlation function. C Default: CKNMAX=999999. 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=1. C D2=real... Grid interval along the X2 axis. C Default: D2=1. C D3=real... Grid interval along the X3 axis. C Default: D3=1. 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,GAMMLN,BESSIK REAL GAMMLN C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C GAMMLN ... File C gammln.for of Numerical Recipes. C BESSIK ... File C bessik.for of Numerical Recipes. 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,DIM2VN,ABSD1,ABSD2,ABSD3 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.) ABSD1=ABS(D1) ABSD2=ABS(D2) ABSD3=ABS(D3) 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 DIM2VN=DIM/2.+VN IF (DIM2VN.NE.0.) THEN C Computing the value of the Gamma function for d/2+N: GAMMA=EXP(GAMMLN(DIM2VN)) C Computing the x-independent part of the correlation function: IF (ACOR.NE.999999.) THEN CKN0=KAPPA*KAPPA*2.**(1.-DIM-VN)*PI**(-DIM/2.)/GAMMA*ACOR**VN ELSE CKN0=KAPPA*KAPPA*2.**(-DIM-2*VN)*PI**(-DIM/2.)* * EXP(GAMMLN(ABS(VN)))/GAMMA ENDIF ENDIF C OPEN(LU2,FILE=FILOUT) C 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 IF (DIM2VN.EQ.0.) THEN C Correlation function is the Dirac distribution C realized by several nonzero values around X0: IF (((N1.EQ.1).OR.(ABS(COOR1-X01).LT.ABSD1)).AND. * ((N2.EQ.1).OR.(ABS(COOR2-X02).LT.ABSD2)).AND. * ((N3.EQ.1).OR.(ABS(COOR3-X03).LT.ABSD3))) THEN CKN=1. IF (N1.NE.1) CKN=CKN*(1-ABS(COOR1-X01)/ABSD1)/ABSD1 IF (N2.NE.1) CKN=CKN*(1-ABS(COOR2-X02)/ABSD2)/ABSD2 IF (N3.NE.1) CKN=CKN*(1-ABS(COOR3-X03)/ABSD3)/ABSD3 ELSE CKN=0. ENDIF ELSE XX=SQRT((COOR(1)-X01)**2+ * (COOR(2)-X02)**2+(COOR(3)-X03)**2) IF (XX.EQ.0.) THEN C The value of correlation function is infinite, C realized by CKNMAX at the point X0: CKN=CKNMAX ELSE IF (ACOR.NE.999999.) THEN C Correlation function is computed according to the C equation 48: 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 C Correlation function is computed according to the C equation 66: CKN=CKN0*XX**(2.*VN) ENDIF ENDIF IF (CKN.GT.CKNMAX) CKN=CKNMAX ENDIF WRITE(LU2,*) CKN 21 CONTINUE 22 CONTINUE 23 CONTINUE C 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 of Numerical Recipes INCLUDE 'bessik.for' C bessik.for of Numerical Recipes INCLUDE 'beschb.for' C beschb.for of Numerical Recipes INCLUDE 'chebev.for' C chebev.for of Numerical Recipes C C======================================================================= Cgrdcor.for 0100666 0000765 0000765 00000026623 11023416420 012423 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: 6.00 C Date: 2006, 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 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 ASOB=positive real... High-pass wavenumber filter corresponding C to replacing the mean value (background) by the random C function smoothed with the Sobolev scalar product given by C file 'sob22.dat', 'sob22l.dat' or 'sob22n.dat': C f(k)=1/[1+(ASOB*k)**(-4)] C where k=SQRT(k1*k1+k2*k2+k3*k3). In fitting regularly C distributed discrete values, ASOB should be chosen as C ASOB=SQRT(ERRMUL*SOBMUL/SQRT(N)) C where ERRMUL is the standard deviation equal for all C discrete points and N is the number of discrete points. C The filter suppresses large heterogeneities. C Default: ASOB=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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. 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 REAL ASOB 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 CALL RSEP3R('ASOB',ASOB,999999.) IF (ASOB.LE.0.) THEN C GRDCOR-06 CALL ERROR('GRDCOR-06: ASOB 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 C Filter corresponding to smoothing with Sobolev norm: IF (ASOB.NE.999999.) THEN IF (XK.EQ.0.) THEN RAM(I4)=0. ELSE RAM(I4)=RAM(I4)/(1.+(ASOB*XK)**(-4)) ENDIF ENDIF 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======================================================================= Cgrdcros.for 0100666 0000765 0000765 00000036520 11023416420 012603 0 ustar bulant bulant C
C Program GRDCROS to calculate autocorrelations and crosscorrelations C of given grid values C C Version: 6.00 C Date: 2006, March 3 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 C Names of input and output files: C GRD1='string',GRD2='string'... Names of two input ASCII files with C the grid values. C Default: GRD1='grd1.out', GRD2=GRD1 C GRD3='string'... Name of the output ASCII file containing the C crosscorrelations of grid values read from files GRD1 and C GRD2. C Default: GRD3='grd3.out' C GRD4='string'... Name of the output ASCII file containing the C numbers of points used to determinine individual C crosscorrelations written to file GRD3, multiplied by the C given cosine window. C Not written if GRD4=' '. C Default: GRD4=' ' C For general description of the files with gridded data refer C to file forms.htm. C C Data specifying dimensions of the input grid: C D1=real... Grid interval in the direction of the first coordinate C axis in files GRD1, GRD2 and GRD3. C Default: D1=1. C D2=real... Grid interval in the direction of the second coordinate C axis in files GRD1, GRD2 and GRD3. C Default: D2=1. C D3=real... Grid interval in the direction of the third coordinate C axis in files GRD1, GRD2 and GRD3. C Default: D3=1. C N11=positive integer... Number of gridpoints along the X1 axis in C input file GRD1. C Default: N11=1 C N21=positive integer... Number of gridpoints along the X2 axis in C input file GRD1. C Default: N21=1 C N31=positive integer... Number of gridpoints along the X3 axis in C input file GRD1. C Default: N31=1 C O11=real... First coordinate of the grid origin (first point of C the grid) in input file GRD1. C Default: O11=0. C O21=real... Second coordinate of the grid origin in input file C GRD1. C Default: O21=0. C O31=real... Third coordinate of the grid origin in input file C GRD1. C Default: O31=0. C N12=positive integer... Number of gridpoints along the X1 axis in C input file GRD2. C Default: N12=N11 C N22=positive integer... Number of gridpoints along the X2 axis in C input file GRD2. C Default: N22=N21 C N32=positive integer... Number of gridpoints along the X3 axis in C input file GRD2. C Default: N32=N31 C O12=real... First coordinate of the grid origin (first point of C the grid) in input file GRD2. C Default: O12=O11 C O22=real... Second coordinate of the grid origin in input file C GRD2. C Default: O22=O21 C O32=real... Third coordinate of the grid origin in input file C GRD2. C Default: O32=O31 C C Data specifying dimensions of the output grid: C N1=positive integer... Number of crosscorrelations (discretized C with step D1) in the direction of the X1 axis. C N1 cannot be greater than N11+N12-1. C Default: N1=N11+N12-1 C N2=positive integer... Number of crosscorrelations (discretized C with step D2) in the direction of the X2 axis. C N2 cannot be greater than N21+N22-1. C Default: N2=N21+N22-1 C N3=positive integer... Number of crosscorrelations (discretized C with step D3) in the direction of the X3 axis. C N3 cannot be greater than N31+N32-1. C Default: N3=N31+N32-1 C O1=real... Shift (in the direction of the X1 axis) of GRD2 with C respect to GRD1 corresponding to the first output C crosscorrelation. C (O1+O12-O11) should equal an integer multiple of D1. C O1 cannot be smaller than O11-O12-(N12-1)*D1 and cannot C be greater than O11+(N11-1)*D1-O12-(N1-1)*D1. C Default: O1=O11-O12-(N12-1)*D1 C O2=real... Shift (in the direction of the X2 axis) of GRD2 with C respect to GRD1 corresponding to the first output C crosscorrelation. C (O2+O22-O21) should equal an integer multiple of D2. C O2 cannot be smaller than O21-O22-(N22-1)*D2 and cannot C be greater than O21+(N21-1)*D2-O22-(N2-1)*D2. C Default: O2=O21-O22-(N22-1)*D2 C O3=real... Shift (in the direction of the X3 axis) of GRD2 with C respect to GRD1 corresponding to the first output C crosscorrelation. C (O3+O32-O31) should equal an integer multiple of D3. C O3 cannot be smaller than O31-O32-(N32-1)*D3 and cannot C be greater than O31+(N31-1)*D3-O32-(N3-1)*D3. C Default: O3=O31-O32-(N32-1)*D3 C C Data specifying the cosine window: C X1MIN=real, X1LOW=real, X1HIGH=real, X1MAX=real... Parameters of C the cosine window in the X1 direction to be applied to C the values in output file GRD4. C If X1MIN.LT.X1MAX, the window is zero for X1 smaller than C X1MIN or greater than X1MAX, and the window equals 1 C between X1LOW and X1HIGH. C If X1MAX.LT.X1MIN, the window is zero for X1 greater than C X1MAX and smaller than X1MIN. Then the window equals 1 C for X1 smaller than X1HIGH or greater than X1LOW. C Between X1MIN and X1LOW, cosine tapering C ( 0.5-0.5*cos(pi*(X1-X1MIN)/(X1LOW-X1MIN)) )**KEXP C is used. C Between X1MIN and X1LOW, cosine tapering C ( 0.5-0.5*cos(pi*(X1-X1MAX)/(X1HIGH-X1MAX)) )**KEXP C is used. C Default: X1MIN=0., X1LOW=0., X1HIGH=0., X1MAX=0. C KEXP=real... Exponent controlling the cosine window. C Usually need not be specified because the default is the C most common option. C Default: KEXP=1 (mostly sufficient) C C Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file 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 ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,UARRAY,WARRAY,RARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3,FILE4 INTEGER LU REAL UNDEF PARAMETER (LU=1) C Input data: INTEGER N1,N2,N3,N11,N21,N31,N12,N22,N32 REAL D1,D2,D3,O1,O2,O3,O11,O21,O31,O12,O22,O32 REAL X1MIN,X1LOW,X1HIGH,X1MAX REAL X2MIN,X2LOW,X2HIGH,X2MAX REAL X3MIN,X3LOW,X3HIGH,X3MAX C Other variables: INTEGER I1,I2,I3,I01,I11,I21,I31,I02,I12,I22,I32 INTEGER I11MIN,I21MIN,I31MIN,I11MAX,I21MAX,I31MAX INTEGER NO1,NO2,NO3,IGRD1,IGRD2,IGRD3,IGRD4,I,IAUX REAL X1,X2,X3,X1WIN,X2WIN,X3WIN,AUX C UNDEF=UARRAY() C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDCROS: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 WRITE(*,'(A)') '+GRDCROS: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILE1.EQ.' ') THEN C GRDCROS-01 CALL ERROR('GRDCROS-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('GRD1',FILE1,'grd1.out') CALL RSEP3T('GRD2',FILE2,FILE2) CALL RSEP3T('GRD3',FILE3,'grd3.out') CALL RSEP3T('GRD4',FILE4,' ') C C Reading grid dimensions: C Input grids: CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) CALL RSEP3I('N11',N11,1) CALL RSEP3I('N21',N21,1) CALL RSEP3I('N31',N31,1) CALL RSEP3R('O11',O11,0.) CALL RSEP3R('O21',O21,0.) CALL RSEP3R('O31',O31,0.) CALL RSEP3I('N12',N12,N11) CALL RSEP3I('N22',N22,N21) CALL RSEP3I('N32',N32,N31) CALL RSEP3R('O12',O12,O11) CALL RSEP3R('O22',O22,O21) CALL RSEP3R('O32',O32,O31) C Output grid: CALL RSEP3I('N1',N1,N11+N12-1) CALL RSEP3I('N2',N2,N21+N22-1) CALL RSEP3I('N3',N3,N31+N32-1) CALL RSEP3R('O1',O1,O11-O12-(N12-1)*D1) CALL RSEP3R('O2',O2,O21-O22-(N22-1)*D2) CALL RSEP3R('O3',O3,O31-O32-(N32-1)*D3) NO1=NINT((O1+O12-O11)/D1) NO2=NINT((O2+O22-O21)/D2) NO3=NINT((O3+O32-O31)/D3) WRITE(*,'(3(A,I4),3(A,F8.3))') * '+GRDCROS: N1=',N1,' N2=',N2,' N3=',N3, * ' O1=',O1,' O2=',O2,' O3=',O3 WRITE(*,'(A)') ' GRDCROS: Working ... ' IF(NO1.LT.1-N12.OR.NO1.GT.N11-N1.OR. * NO2.LT.1-N22.OR.NO2.GT.N21-N2.OR. * NO3.LT.1-N32.OR.NO3.GT.N31-N3) THEN C GRDCROS-02 CALL ERROR('GRDCROS-02: Incorrect N1, N2, N3, O1, O2 or O3') C N1, N2, N3, O1, O2 or O3 do not satisfy the inequalities set C in the description of the input data. END IF C C Reading the parameters of the cosine window: CALL RSEP3R('X1MIN' ,X1MIN ,0.) CALL RSEP3R('X1LOW' ,X1LOW ,0.) CALL RSEP3R('X1HIGH',X1HIGH,0.) CALL RSEP3R('X1MAX' ,X1MAX ,0.) CALL RSEP3R('X2MIN' ,X2MIN ,0.) CALL RSEP3R('X2LOW' ,X2LOW ,0.) CALL RSEP3R('X2HIGH',X2HIGH,0.) CALL RSEP3R('X2MAX' ,X2MAX ,0.) CALL RSEP3R('X3MIN' ,X3MIN ,0.) CALL RSEP3R('X3LOW' ,X3LOW ,0.) CALL RSEP3R('X3HIGH',X3HIGH,0.) CALL RSEP3R('X3MAX' ,X3MAX ,0.) C IGRD1=N1*N2*N3 IGRD2=IGRD1+N11*N21*N31 IGRD3=IGRD2+N12*N22*N32 IGRD4=IGRD3 IF(FILE4.NE.' ') THEN IGRD4=IGRD3+N1*N2*N3 END IF IF(IGRD4.GT.MRAM) THEN C GRDCROS-03 CALL ERROR('GRDCROS-03: 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: CALL RARRAY(LU,FILE1,'FORMATTED',.TRUE.,UNDEF, * N11*N21*N31,RAM(IGRD1+1)) CALL RARRAY(LU,FILE2,'FORMATTED',.TRUE.,UNDEF, * N12*N22*N32,RAM(IGRD2+1)) C C Calculating crossvariances: I=0 DO 23 I3=NO3,NO3+N3-1 I31MIN=MAX0(0,I3) I31MAX=MIN0(N31-1,N32-1+I3) X3=O3+D3*FLOAT(I3-NO3) X3WIN=1. IF(X3MAX.LE.X3MIN) THEN X3WIN=1.-X3WIN END IF IF(X3.LT.X3MIN) THEN X3WIN=1.-X3WIN END IF IF(X3MAX.LE.X3) THEN X3WIN=1.-X3WIN END IF DO 22 I2=NO2,NO2+N2-1 I21MIN=MAX0(0,I2) I21MAX=MIN0(N21-1,N22-1+I2) X2=O2+D2*FLOAT(I2-NO2) X2WIN=1. IF(X2MAX.LE.X2MIN) THEN X2WIN=1.-X2WIN END IF IF(X2.LT.X2MIN) THEN X2WIN=1.-X2WIN END IF IF(X2MAX.LE.X2) THEN X2WIN=1.-X2WIN END IF DO 21 I1=NO1,NO1+N1-1 I11MIN=MAX0(0,I1)+1 I11MAX=MIN0(N11-1,N12-1+I1)+1 X1=O1+D1*FLOAT(I1-NO1) X1WIN=1. IF(X1MAX.LE.X1MIN) THEN X1WIN=1.-X1WIN END IF IF(X1.LT.X1MIN) THEN X1WIN=1.-X1WIN END IF IF(X1MAX.LE.X1) THEN X1WIN=1.-X1WIN END IF AUX=0. DO 13 I31=I31MIN,I31MAX I32=I31-I3 DO 12 I21=I21MIN,I21MAX I22=I21-I2 I01=IGRD1+N11*(N21*I31+I21) I02=IGRD2+N12*(N22*I32+I22) DO 11 I11=I11MIN,I11MAX I12=I11-I1 AUX=AUX+RAM(I01+I11)*RAM(I02+I12) 11 CONTINUE 12 CONTINUE 13 CONTINUE I=I+1 IAUX=(I11MAX-I11MIN+1)*(I21MAX-I21MIN+1)*(I31MAX-I31MIN+1) RAM(I)=AUX/FLOAT(IAUX) IF(FILE4.NE.' ') THEN RAM(IGRD3+I)=FLOAT(IAUX)*X1WIN*X2WIN*X3WIN END IF 21 CONTINUE 22 CONTINUE 23 CONTINUE C C Writing output grid values: CALL WARRAY(LU,FILE3,'FORMATTED',.FALSE.,0.,.FALSE.,0., * N1*N2*N3,RAM) IF(FILE4.NE.' ') THEN CALL WARRAY(LU,FILE4,'FORMATTED',.FALSE.,0.,.FALSE.,0., * N1*N2*N3,RAM(IGRD3+1)) END IF WRITE(*,'(A)') '+GRDCROS: 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 00000043412 11023416420 012224 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: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY 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) 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 UNDEF=UARRAY() 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 error.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 00000103562 11023416420 012415 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: 6.00 C Date: 2005, November 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 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL NFFT,INDRAM,MODF,NCHECK,ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I, *RARRAY,WARRAY,FOURN,UARRAY REAL UARRAY INTEGER NFFT,INDRAM,MODF C NFFT,INDRAM,MODF,NCHECK ... This file. C ERROR ... File C error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... File C sep.for. C RARRAY,WARRAY,UARRAY ... File C forms.for. C FOURN ... File 'fourn.for' of C Numerical Recipes. 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) DOUBLE PRECISION PID PARAMETER (PID=3.141592653589793D0) 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 REAL O1,O2,O3,D1,D2,D3,FFT,FFTFIL, * 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,M1,M2,M3 INTEGER IRAM,I1,I2,I3,I4,I,J,K,L,NDIMFF,NFORFF,OFORFF REAL RRA,RRB,RR0,RRD,RIA,RIB,RI0,RID,RRK DOUBLE PRECISION FFTD,O1D,O2D,O3D,D1D,D2D,D3D,M1D,M2D,M3D, * D1OUTD,D2OUTD,D3OUTD,O1OUTD,O2OUTD,O3OUTD, * AUXD,AUXRD,AUXID,RM0RD,RM0ID,RMTRD,RMTID,RMULTD C UNDEF=UARRAY() C 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) FFTD=DBLE(FFT) 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 FFTD=DBLE(I)*PID 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.') C The dimension MRAM in the common block RAMC defined in the file C ram.inc should be C at least 2*(N1FFT*N2FFT*N3FFT + C + MAX(N1*N2*N3,N1OUT*N2OUT*N3OUT,N1FFT*N2FFT*N3FFT). ENDIF C C Preparing the quantities needed in double precision: O1D=DBLE(O1) O2D=DBLE(O2) O3D=DBLE(O3) D1D=DBLE(D1) D2D=DBLE(D2) D3D=DBLE(D3) D1OUTD=DBLE(D1OUT) D2OUTD=DBLE(D2OUT) D3OUTD=DBLE(D3OUT) O1OUTD=DBLE(O1OUT) O2OUTD=DBLE(O2OUT) O3OUTD=DBLE(O3OUT) C Preparing number NDIMFF describing the dimension C of the part of the input grid to be transformed. NDIMFF=3 IF ((N1FFT.EQ.1).OR.(NT1FFT.EQ.0)) NDIMFF=NDIMFF-1 IF ((N2FFT.EQ.1).OR.(NT2FFT.EQ.0)) NDIMFF=NDIMFF-1 IF ((N3FFT.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: RMULTD=1.D0 IF ((N1FFT.NE.1).AND.(NT1FFT.NE.0)) RMULTD=RMULTD*D1D IF ((N2FFT.NE.1).AND.(NT2FFT.NE.0)) RMULTD=RMULTD*D2D IF ((N3FFT.NE.1).AND.(NT3FFT.NE.0)) RMULTD=RMULTD*D3D RMULTD=RMULTD*DSQRT(DABS(FFTD)/(2.D0*PID))**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+1 II=MRAM-NN+1 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 WRITE(*,'(A)') '+GRDFFT: Working... ' C I=N1FFT-N1 M1=I/2 M1D=DBLE(M1) I1MI=1+M1 I1MA=M1+N1 I=N2FFT-N2 M2=I/2 M2D=DBLE(M2) I2MI=1+M2 I2MA=M2+N2 I=N3FFT-N3 M3=I/2 M3D=DBLE(M3) I3MI=1+M3 I3MA=M3+N3 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 C Recording the known values: IRAM=1 DO 24, I3=1,N3FFT DO 23, I2=1,N2FFT DO 22, I1=1,N1FFT IF (IRAM+1.GE.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=IR + I1-I1MI + (I2-I2MI)*N1 + (I3-I3MI)*N1N2 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 Adding the before-FFT multiplicative factor: DO 58, I3=1,N3FFT DO 57, I2=1,N2FFT DO 56, I1=1,N1FFT RMTRD=1.D0 RMTID=0.D0 IF ((N1FFT.NE.1).AND.(NT1FFT.NE.0)) THEN AUXD=FFTD* * (DBLE(I1-1)*D1D*(O1OUTD-DBLE(NINT(O1OUT/D1OUT))*D1OUTD)) AUXRD=DCOS(AUXD) AUXID=DSIN(AUXD) RM0RD=RMTRD RM0ID=RMTID RMTRD=RM0RD*AUXRD - RM0ID*AUXID RMTID=RM0RD*AUXID + RM0ID*AUXRD ENDIF IF ((N2FFT.NE.1).AND.(NT2FFT.NE.0)) THEN AUXD=FFTD* * (DBLE(I2-1)*D2D*(O2OUTD-DBLE(NINT(O2OUT/D2OUT))*D2OUTD)) AUXRD=DCOS(AUXD) AUXID=DSIN(AUXD) RM0RD=RMTRD RM0ID=RMTID RMTRD=RM0RD*AUXRD - RM0ID*AUXID RMTID=RM0RD*AUXID + RM0ID*AUXRD ENDIF IF ((N3FFT.NE.1).AND.(NT3FFT.NE.0)) THEN AUXD=FFTD* * (DBLE(I3-1)*D3D*(O3OUTD-DBLE(NINT(O3OUT/D3OUT))*D3OUTD)) AUXRD=DCOS(AUXD) AUXID=DSIN(AUXD) RM0RD=RMTRD RM0ID=RMTID RMTRD=RM0RD*AUXRD - RM0ID*AUXID RMTID=RM0RD*AUXID + RM0ID*AUXRD ENDIF RM0RD=DBLE(RAM(INDRAM(I1,I2,I3) )) RM0ID=DBLE(RAM(INDRAM(I1,I2,I3)+1)) RAM(INDRAM(I1,I2,I3) )=SNGL(RM0RD*RMTRD - RM0ID*RMTID) RAM(INDRAM(I1,I2,I3)+1)=SNGL(RM0ID*RMTRD + RM0RD*RMTID) 56 CONTINUE 57 CONTINUE 58 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 FFT 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 FFT loop over subgrids. C C Reordering the computed values to the output field, C adding the multiplicative factor: IO1=MODF(NINT(O1OUT/D1OUT)+1,N1FFT) IF (IO1.LT.0) IO1=IO1+N1FFT IO2=MODF(NINT(O2OUT/D2OUT)+1,N2FFT) IF (IO2.LT.0) IO2=IO2+N2FFT IO3=MODF(NINT(O3OUT/D3OUT)+1,N3FFT) IF (IO3.LT.0) IO3=IO3+N3FFT IF ((IO1.LE.0).OR.(IO2.LE.0).OR.(IO3.LE.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 IR=MRAM-2*NNOUT+1 II=MRAM-NNOUT+1 DO 74, I3=1,N3OUT DO 73, I2=1,N2OUT DO 72, I1=1,N1OUT I=INDRAM(MODF(IO1+I1-1,N1FFT),MODF(IO2+I2-1,N2FFT), * MODF(IO3+I3-1,N3FFT)) RMTRD=RMULTD RMTID=DBLE(0.) IF ((N1FFT.NE.1).AND.(NT1FFT.NE.0)) THEN AUXD=FFTD*(O1OUTD+DBLE(I1-1)*D1OUTD)*(O1D-M1D*D1D) AUXRD=DCOS(AUXD) AUXID=DSIN(AUXD) RM0RD=RMTRD RM0ID=RMTID RMTRD=RM0RD*AUXRD - RM0ID*AUXID RMTID=RM0RD*AUXID + RM0ID*AUXRD ENDIF IF ((N2FFT.NE.1).AND.(NT2FFT.NE.0)) THEN AUXD=FFTD*(O2OUTD+DBLE(I2-1)*D2OUTD)*(O2D-M2D*D2D) AUXRD=DCOS(AUXD) AUXID=DSIN(AUXD) RM0RD=RMTRD RM0ID=RMTID RMTRD=RM0RD*AUXRD - RM0ID*AUXID RMTID=RM0RD*AUXID + RM0ID*AUXRD ENDIF IF ((N3FFT.NE.1).AND.(NT3FFT.NE.0)) THEN AUXD=FFTD*(O3OUTD+DBLE(I3-1)*D3OUTD)*(O3D-M3D*D3D) AUXRD=DCOS(AUXD) AUXID=DSIN(AUXD) RM0RD=RMTRD RM0ID=RMTID RMTRD=RM0RD*AUXRD - RM0ID*AUXID RMTID=RM0RD*AUXID + RM0ID*AUXRD ENDIF RM0RD=DBLE(RAM(I)) RM0ID=DBLE(RAM(I+1)) RAM(IR)=SNGL(RM0RD*RMTRD - RM0ID*RMTID) RAM(II)=SNGL(RM0ID*RMTRD + RM0RD*RMTID) IR=IR+1 II=II+1 72 CONTINUE 73 CONTINUE 74 CONTINUE C C C Writing the results of the FFT: IR=MRAM-2*NNOUT+1 II=MRAM-NNOUT+1 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 MODF=MOD(I,J) IF (MODF.EQ.0) MODF=J RETURN END C C======================================================================= C INTEGER FUNCTION NFFT(N) INTEGER N IF (N.LE. 1) THEN NFFT= 1 ELSEIF (N.LE. 2) THEN NFFT= 2 ELSEIF (N.LE. 4) THEN NFFT= 4 ELSEIF (N.LE. 8) THEN NFFT= 8 ELSEIF (N.LE. 16) THEN NFFT= 16 ELSEIF (N.LE. 32) THEN NFFT= 32 ELSEIF (N.LE. 64) THEN NFFT= 64 ELSEIF (N.LE. 128) THEN NFFT= 128 ELSEIF (N.LE. 256) THEN NFFT= 256 ELSEIF (N.LE. 512) THEN NFFT= 512 ELSEIF (N.LE. 1024) THEN NFFT= 1024 ELSEIF (N.LE. 2048) THEN NFFT= 2048 ELSEIF (N.LE. 4096) THEN NFFT= 4096 ELSEIF (N.LE. 8192) THEN NFFT= 8192 ELSEIF (N.LE. 16384) THEN NFFT= 16384 ELSEIF (N.LE. 32768) THEN NFFT= 32768 ELSEIF (N.LE. 65536) THEN NFFT= 65536 ELSEIF (N.LE. 131072) THEN NFFT= 131072 ELSEIF (N.LE. 262144) THEN NFFT= 262144 ELSEIF (N.LE. 524288) THEN NFFT= 524288 ELSEIF (N.LE. 1048576) THEN NFFT= 1048576 ELSEIF (N.LE. 2097152) THEN NFFT= 2097152 ELSEIF (N.LE. 4194304) THEN NFFT= 4194304 ELSEIF (N.LE. 8388608) THEN NFFT= 8388608 ELSEIF (N.LE. 16777216) THEN NFFT= 16777216 ELSEIF (N.LE. 33554432) THEN NFFT= 33554432 ELSEIF (N.LE. 67108864) THEN NFFT= 67108864 ELSEIF (N.LE. 134217728) THEN NFFT= 134217728 ELSEIF (N.LE. 268435456) THEN NFFT= 268435456 ELSEIF (N.LE. 536870912) THEN NFFT= 536870912 ELSEIF (N.LE.1073741824) THEN NFFT=1073741824 ELSE C GRDFFT-09 CALL ERROR ('GRDFFT-09: Too large N') C One of the N1, N2, N3 or N4 is greater than 2**31. ENDIF cc Old: cc REAL AUX cc AUX=LOG10(FLOAT(N))/LOG10(2.) cc NFFT=2**INT(AUX+0.999999) 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 grid for FFT') 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 grid for FFT') 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 '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 C C======================================================================= Cgrdgse.for 0100666 0000765 0000765 00000016725 11023416420 012420 0 ustar bulant bulant C
C Program GRDGSE to convert the gridded data into the GSE format C C Version: 6.00 C Date: 2005, November 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 Names of the input and output files: C GRD1='string'... Name of the input ASCII file with the grid C values to be understood as the first component of C the seismograms. C Default: GRD1=' ' C GRD2='string'... Name of the input ASCII file with the grid C values to be understood as the second component of C the seismograms. C Default: GRD2=' ' C GRD3='string'... Name of the input ASCII file with the grid C values to be understood as the third component of C the seismograms. C Default: GRD3=' ' C For general description of the files with gridded data refer C to file forms.htm. C SS='string'... Name of the output file containing the C input grid values written in the C GSE format. C Default: SS='ss.gse' C Data specifying dimensions of the input grid: C N1=positive integer... Number of gridpoints along the faster C axis (inner loop). The gridpoints are understood as C the time samples along individual seismograms. C Default: N1=1 C N2=positive integer... Number of gridpoints along the slower C axis (outer loop). The gridpoints are understood to C correspond to individual seismograms. C (N2 seismograms, each of them consisting of N1 points) C Default: N2=1 C Data specifying the time axis of the seismograms: C TSTART=real ... Start time, i.e. the time corresponding to C the first sample in seconds. C Default: TSTART=0. C TSTEP=real ... Time step between samples. C Default: TSTEP=1. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FSEP,FGRD1,FGRD2,FGRD3,FGSE CHARACTER*6 TEXT INTEGER LU REAL UNDEF PARAMETER (LU=1) INTEGER NCOMP,N1,N2,N1N2,IGRD1,IGRD2,JGRD1,JGRD2,IGRD3,JGRD3,I1,I2 REAL TSTART,TSTEP C UNDEF=UARRAY() C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+GRDGSE: Enter input filename: ' FSEP=' ' READ(*,*) FSEP WRITE(*,'(A)') '+GRDGSE: Working ... ' C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU,FSEP) ELSE C GRDGSE-01 CALL ERROR('GRDGSE-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('GRD1' ,FGRD1,' ' ) CALL RSEP3T('GRD2' ,FGRD2,' ' ) CALL RSEP3T('GRD3' ,FGRD3,' ' ) CALL RSEP3T('SS' ,FGSE ,'ss.gse' ) CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3R('TSTART',TSTART,0.) CALL RSEP3R('TSTEP',TSTEP,1.) C Number of components: NCOMP=0 IF (FGRD1.NE.' ') NCOMP=NCOMP+1 IF (FGRD2.NE.' ') NCOMP=NCOMP+1 IF (FGRD3.NE.' ') NCOMP=NCOMP+1 IF(NCOMP.EQ.0) THEN C GRDGSE-02 CALL ERROR('GRDGSE-02: No input grid given') C At least one of the files with seismogram components C should be specified. END IF N1N2=N1*N2 IF(NCOMP*N1N2.GT.MRAM) THEN C GRDGSE-03 CALL ERROR('GRDGSE-03: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too small C to contain the input grids (NCOMP*N1*N2 values). You may C wish to increase the dimension MRAM in file 'ram.inc'. C ram.inc END IF C C Reading input grids: IGRD1=1 IF (FGRD1.NE.' ') THEN CALL RARRAY(LU,FGRD1,'FORMATTED',.TRUE.,UNDEF,N1N2,RAM(IGRD1)) JGRD1=N1N2 ELSE JGRD1=0 ENDIF IGRD2=JGRD1+1 IF (FGRD2.NE.' ') THEN CALL RARRAY(LU,FGRD2,'FORMATTED',.TRUE.,UNDEF,N1N2,RAM(IGRD2)) JGRD2=JGRD1+N1N2 ELSE JGRD2=JGRD1 ENDIF IGRD3=JGRD2+1 IF (FGRD3.NE.' ') THEN CALL RARRAY(LU,FGRD3,'FORMATTED',.TRUE.,UNDEF,N1N2,RAM(IGRD3)) JGRD3=JGRD2+N1N2 ELSE JGRD3=JGRD2 ENDIF C C Writing the output GSE file: OPEN(LU,FILE=FGSE) CALL WGSE1(LU,' ') TEXT='000000' DO 10, I1=1,N2 C Name of the channel (for 999999 channels at the most): DO 20, I2=0,6-1 TEXT(6-I2:6-I2)= * CHAR(ICHAR('0')+MOD(I1,10**(I2+1))/10**I2) 20 CONTINUE IF (FGRD1.NE.' ') THEN CALL WGSE2(LU,TEXT,' ',1,-999.,-999.,-999., * TSTART,TSTEP,N1,RAM(IGRD1+(I1-1)*N1)) ENDIF IF (FGRD2.NE.' ') THEN CALL WGSE2(LU,TEXT,' ',2,-999.,-999.,-999., * TSTART,TSTEP,N1,RAM(IGRD2+(I1-1)*N1)) ENDIF IF (FGRD3.NE.' ') THEN CALL WGSE2(LU,TEXT,' ',3,-999.,-999.,-999., * TSTART,TSTEP,N1,RAM(IGRD3+(I1-1)*N1)) ENDIF 10 CONTINUE CALL WGSE3(LU) CLOSE(LU) C WRITE(*,'(A)') '+GRDGSE: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'gse.for' C gse.for INCLUDE 'forms.for' C forms.for INCLUDE 'length.for' C length.for 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 00000041166 11023416420 012431 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: 6.00 C Date: 2005, November 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 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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 ... File forms.for. C C Common block /GIC/: INCLUDE 'grdiso.inc' C grdiso.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY 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 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 UNDEF=UARRAY() 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 00000002003 11023416420 012377 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 00000015330 11023416420 012730 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: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY C INTEGER LU,N1,N2,N3,N1N2N3,I REAL UNDEF PARAMETER (LU=1) CHARACTER*80 FSEP,FGRD1,FGRD2,FGRD,FGRDA LOGICAL LGRDA C UNDEF=UARRAY() 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======================================================================= Cgrdmigr.for 0100666 0000765 0000765 00000022603 11023416420 012570 0 ustar bulant bulant C
C Program GRDMIGR to perform common-source Kirchhoff migration C C Version: 5.90 C Date: 2005, June 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 MIGR='string'... Name of the input ASCII file containing the C names of files with grid values of travel times and C amplitudes. C Default: MIGR='migr.dat' C GRDSEIS='string'... Name of the input ASCII file with seismograms. C File contains NSEIS*NREC real values. C Default: GRDSEIS='grdseis.out' C GRDMIGR='string'... Name of the output ASCII file containing the C grid values of the migrated image. C Default: GRDNEW='grdmigr.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). C Default: N3=1 C NSEIS=positive integer... Number of points of a seismogram. C Default: NSEIS=1 C OSEIS=real... Time of the first sample of a seismogram. C Default: OSEIS=0. C DSEIS=real... Sampling interval of a seismogram. C Default: DSEIS=1. C ISRC=positive integer... Index of the line in file MIGR C corresponding to the source. C Default: ISRC=1 C IREC=positive integer... Index of the line in file MIGR C corresponding to the first receiver. C Default: IREC=1 C NREC=positive integer... Number of receivers. C Receivers IREC to IREC+NREC-1 are thus considered. C Default: NREC=1 C TAPER=real... Cosine windowing of seismograms. The width of C cosine windows is TAPER intervals between receivers. C The first cosine window starts at receiver IREC-1, the C second cosine window ends at receiver IREC+NREC. C Default: TAPER=0. C Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C C Input formatted file MIGR: C For each surface point, the following line: C (1) 'GRDNUM','GRDTT','GRDAMP','GRDAKI',/ C 'GRDNUM'... Any string. Reserved for future extension. C 'GRDTT'... Gridded travel times from the surface point. C 'GRDAMP'... Gridded ray-theory amplitudes from the surface point. C 'GRDAKI'... Gridded amplitudes, modified for the Kirchhoff C integral, corresponding to the surface point. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C C Filenames and parameters: CHARACTER*80 FSEP,FNAMES,FSEIS,FMIGR,FILNUM,FILTT,FILAMP,FILAKI INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) C C Input data: INTEGER N1,N2,N3,NSEIS,ISRC,IREC,NREC REAL OSEIS,DSEIS,TAPER C C Memory allocation: INTEGER ISEIS,IMIGR,ITT1,IAMP1,ITT2,IAMP2,NRAM C C Other variables: INTEGER N123,I1,I2,I3,I4,I,IT,ISEIS1 REAL WEIGHT,AMP1,AMP2,A,TT,DT C C----------------------------------------------------------------------- C C Reading input SEP parameter file: WRITE(*,'(A)') '+GRDMIGR: Enter input filename: ' FSEP=' ' READ(*,*) FSEP IF (FSEP.EQ.' ') THEN C GRDMIGR-01 CALL ERROR('GRDMIGR-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(LU1,FSEP) WRITE(*,'(A)') '+GRDMIGR: Working ... ' C C Reading input parameters from the SEP file: CALL RSEP3T('MIGR',FNAMES,'migr.dat') CALL RSEP3T('GRDSEIS',FSEIS,'grdseis.out') CALL RSEP3T('GRDMIGR',FMIGR,'grdmigr.out') CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) N123=N1*N2*N3 CALL RSEP3I('NSEIS',NSEIS,1) CALL RSEP3R('OSEIS',OSEIS,0.) CALL RSEP3R('DSEIS',DSEIS,1.) CALL RSEP3I('ISRC',ISRC,1) CALL RSEP3I('IREC',IREC,1) CALL RSEP3I('NREC',NREC,1) CALL RSEP3R('TAPER',TAPER,0.) C C Memory allocation: ISEIS=0 IMIGR=ISEIS+NSEIS*NREC ITT1 =IMIGR+N123 IAMP1=ITT1 +N123 ITT2 =IAMP1+N123 IAMP2=ITT2 +N123 NRAM =IAMP2+N123 IF(NRAM.GT.MRAM) THEN C GRDMIGR-02 CALL ERROR('GRDMIGR-02: Too small array RAM(MRAM)') C Array RAM(MRAM) allocated in include file 'ram.inc' is too small C to contain both input and output grids. C You may wish to increase the dimension MRAM in file C ram.inc. END IF C C Reading the seismograms: CALL RARRAY * (LU2,FSEIS,'FORMATTED',.TRUE.,0.,NSEIS*NREC,RAM(ISEIS+1)) C C Initializing the image: I=0 DO 13 I3=1,N3 DO 12 I2=1,N2 DO 11 I1=1,N1 I=I+1 RAM(IMIGR+I)=0. 11 CONTINUE 12 CONTINUE 13 CONTINUE C C Reading the source grid: OPEN(LU1,FILE=FNAMES,FORM='formatted',STATUS='old') DO 14 I4=1,ISRC READ(LU1,*) FILNUM,FILTT,FILAMP,FILAKI 14 CONTINUE CALL RARRAY(LU2,FILTT ,'FORMATTED',.TRUE.,0.,N123,RAM(ITT1 +1)) CALL RARRAY(LU2,FILAMP,'FORMATTED',.TRUE.,0.,N123,RAM(IAMP1+1)) C C Finding the first receiver grid: REWIND(LU1) DO 15 I4=1,IREC-1 READ(LU1,*) FILNUM,FILTT,FILAMP,FILAKI 15 CONTINUE C C Loop over the receivers: ISEIS1=ISEIS-NSEIS+1 DO 24 I4=1,NREC ISEIS1=ISEIS1+NSEIS READ(LU1,*) FILNUM,FILTT,FILAMP,FILAKI CALL RARRAY(LU2,FILTT ,'FORMATTED',.TRUE.,0.,N123,RAM(ITT2 +1)) CALL RARRAY(LU2,FILAKI,'FORMATTED',.TRUE.,0.,N123,RAM(IAMP2+1)) C C Cosine window: WEIGHT=1. IF(FLOAT(I4).LT.TAPER) THEN WEIGHT=0.5-0.5*COS(3.14159*FLOAT(I4)/TAPER) END IF IF(FLOAT(NREC-I4+1).LT.TAPER) THEN WEIGHT=(0.5-0.5*COS(3.14159*FLOAT(NREC-I4+1)/TAPER))*WEIGHT END IF C C Loop over the depth points I=0 DO 23 I3=1,N3 DO 22 I2=1,N2 DO 21 I1=1,N1 I=I+1 A=0. AMP1=RAM(IAMP1+I) AMP2=RAM(IAMP2+I) IF(AMP1.GT.0..AND.AMP2.GT.0.) THEN TT=(RAM(ITT1+I)+RAM(ITT2+I)-OSEIS)/DSEIS IT=INT(TT) IF(0..LE.TT.AND.IT.LT.NSEIS) THEN DT=TT-FLOAT(IT) IT=ISEIS1+IT A=(1.-DT)*RAM(IT)+DT*RAM(IT+1) A=A*AMP2/AMP1 END IF END IF RAM(IMIGR+I)=RAM(IMIGR+I)+WEIGHT*A 21 CONTINUE 22 CONTINUE 23 CONTINUE C 24 CONTINUE C C Writing the migrated image: CALL WARRAY * (LU2,FMIGR,'FORMATTED',.FALSE.,0.,.FALSE.,0.,N123,RAM(IMIGR+1)) CLOSE(LU1) WRITE(*,'(A,I8,A)') '+GRDMIGR: Done (source',ISRC,'). ' 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 00000024425 11023416420 012427 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: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3 INTEGER LU REAL UNDEF PARAMETER (LU=1) 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 UNDEF=UARRAY() 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 00000035405 11023416420 012611 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: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3 INTEGER LU REAL UNDEF PARAMETER (LU=1) 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 UNDEF=UARRAY() 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 00000075610 11023416420 012262 0 ustar bulant bulant C
C Program GRDPS to Display GRiD values in Post Script C C Version: 6.00 C Date: 2005, November 12 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 EXTERNAL UARRAY REAL UARRAY 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 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 UNDEF=UARRAY() 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 00000050257 11024140020 012435 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: 6.20 C Date: 2008, June 12 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 files: C GRD='string',GRD1='string',GRD2='string',...,GRD9='string'... C Strings with the names of the input data files containing C the grid values. C These files are used only if KOLUMN.NE.0, KOLUMN1.NE.0, C KOLUMN2.NE.0, ..., KOLUMN9.NE.0, respectively, see below. C The grids 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 written in the form C POINTS. C The file is not generated if PTS=' '. C Default: PTS='pts.out' C LIN='string'...Name of the optional output file with the C coordinates of the gridpoints written in the form C LINES. The N2*N3 lines C is generated, each line consisting of N1 points. C Default: LIN=' ' (no file generated). 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 C 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,KOLUMN1=integer,KOLUMN2=integer,..., C KOLUMN9=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 the grid values. C KOLUMN*=4,5,...: The grid values are written after the C three coordinates, into the specified numeric column. C KOLUMN*=-1, -2 or -3: The grid values are added to C the corresponding coordinate. 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 Optional parameters specifying the form of the real quantities C written to the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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,/ or C 'NNNNNN',X1,X2,X3,X4,X5,/ etc. 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, or the value at C the gridpoint, see parameter KOLUMN. C X4,X5,...,X9... Optional grid values. C (3) / C C C Optional output file LIN with the gridlines: C (1) / C (2) For each of the N2*N3 gridlines data (2.1) and (2.2): C (2.1) 'NNNNNN',X1,X2,X3,/ C 'NNNNNN'... Name of the line - six-digit integer index of the C gridline, the first three digits correspond to the index C along the second axis, and the second three digits C correspond to the third axis (larger grids than N2=999 C and N3=999 are not expected to be converted into this form C suitable for a reasonably small number of points). C X1,X2,X3... Coordinates of the first gridpoint of the gridline, C or the value at the gridpoint, see parameter KOLUMN. C (2.2) Points of the line - for each point of the line (2.2.1): C (2.2.1) X1,X2,X3,/ or C X1,X2,X3,X4,/ or C X1,X2,X3,X4,X5,/ etc. C X1,X2,X3... Coordinates of the gridpoint of the gridline, C or the value at the gridpoint, see parameter KOLUMN. C X4,X5,...,X9... Optional grid values at the gridpoint of the C line. C (2.3) / (a slash indicating end of the line). C (3) / (a slash indicating end of file). 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 EXTERNAL UARRAY REAL UARRAY C Filenames and parameters: CHARACTER*80 FILSEP,FGRD(0:9),FLIN,FPTS,FPLGN,FTRGL INTEGER LU,LU2 REAL UNDEF PARAMETER (LU=1,LU2=2) C C Input data: INTEGER KOLUMN(0:9),N1,N2,N3,N1N2N3 REAL O1,O2,O3,D1,D2,D3 C C Other variables: CHARACTER*47 FORMA1,FORMA2,FORMA3 LOGICAL LWRITE INTEGER NCOL,N,I,I1,I2,I3,J1,J2,J3,J4,K,KCOL REAL X(9),X1,X2,X3 EQUIVALENCE (X(1),X1),(X(2),X2),(X(3),X3) C UNDEF=UARRAY() 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(0),' ') CALL RSEP3T('GRD1',FGRD(1),' ') CALL RSEP3T('GRD2',FGRD(2),' ') CALL RSEP3T('GRD3',FGRD(3),' ') CALL RSEP3T('GRD4',FGRD(4),' ') CALL RSEP3T('GRD5',FGRD(5),' ') CALL RSEP3T('GRD6',FGRD(6),' ') CALL RSEP3T('GRD7',FGRD(7),' ') CALL RSEP3T('GRD8',FGRD(8),' ') CALL RSEP3T('GRD9',FGRD(9),' ') CALL RSEP3T('PTS' ,FPTS ,'pts.out') CALL RSEP3T('LIN' ,FLIN,' ') CALL RSEP3T('PLGN',FPLGN,' ') CALL RSEP3T('TRGL',FTRGL,' ') CALL RSEP3I('KOLUMN' ,KOLUMN(0),0) CALL RSEP3I('KOLUMN1',KOLUMN(1),0) CALL RSEP3I('KOLUMN2',KOLUMN(2),0) CALL RSEP3I('KOLUMN3',KOLUMN(3),0) CALL RSEP3I('KOLUMN4',KOLUMN(4),0) CALL RSEP3I('KOLUMN5',KOLUMN(5),0) CALL RSEP3I('KOLUMN6',KOLUMN(6),0) CALL RSEP3I('KOLUMN7',KOLUMN(7),0) CALL RSEP3I('KOLUMN8',KOLUMN(8),0) CALL RSEP3I('KOLUMN9',KOLUMN(9),0) IF (KOLUMN(0).NE.0.AND.FGRD(0).EQ.' '.OR. * KOLUMN(1).NE.0.AND.FGRD(1).EQ.' '.OR. * KOLUMN(2).NE.0.AND.FGRD(2).EQ.' '.OR. * KOLUMN(3).NE.0.AND.FGRD(3).EQ.' '.OR. * KOLUMN(4).NE.0.AND.FGRD(4).EQ.' '.OR. * KOLUMN(5).NE.0.AND.FGRD(5).EQ.' '.OR. * KOLUMN(6).NE.0.AND.FGRD(6).EQ.' '.OR. * KOLUMN(7).NE.0.AND.FGRD(7).EQ.' '.OR. * KOLUMN(8).NE.0.AND.FGRD(8).EQ.' '.OR. * KOLUMN(9).NE.0.AND.FGRD(9).EQ.' ') THEN C GRDPTS-02 CALL ERROR('GRDPTS-02: 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(0),KOLUMN(1),KOLUMN(2),KOLUMN(3),KOLUMN(4), * KOLUMN(5),KOLUMN(6),KOLUMN(7),KOLUMN(8),KOLUMN(9)) K =MIN0(0,KOLUMN(0),KOLUMN(1),KOLUMN(2),KOLUMN(3),KOLUMN(4), * KOLUMN(5),KOLUMN(6),KOLUMN(7),KOLUMN(8),KOLUMN(9)) KCOL=MAX0(0,KOLUMN(0),KOLUMN(1),KOLUMN(2),KOLUMN(3),KOLUMN(4), * KOLUMN(5),KOLUMN(6),KOLUMN(7),KOLUMN(8),KOLUMN(9))-K IF(K.LT.-3.OR.NCOL.GT.9) THEN C GRDPTS-03 CALL ERROR('GRDPTS-03: Wrong value of KOLUMN*') C KOLUMN* must be -3,-2,-1,0,1,2,3,...,9. ENDIF DO 11 K=1,NCOL X(K)=0. 11 CONTINUE DO 12 K=0,9 IF(KOLUMN(K).NE.0) THEN X(IABS(KOLUMN(K)))=X(IABS(KOLUMN(K)))+1. ENDIF 12 CONTINUE DO 13 K=1,NCOL IF(X(K).GT.1.5) THEN C GRDPTS-04 CALL ERROR('GRDPTS-04: Two equal values of KOLUMN*') C Two different grids cannot correspond to the same column. ENDIF 13 CONTINUE DO 14 K=4,NCOL IF(X(K).LT.0.5) THEN C GRDPTS-05 CALL ERROR('GRDPTS-05: Empty column in output files') C There is a column corresponding to no grid. C The values of KOLUMN* cannot form a gap. ENDIF 14 CONTINUE 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.) N1N2N3=N1*N2*N3 C C Writing output points or lines: IF((FPTS.NE.' ').OR.(FLIN.NE.' ')) THEN DO 19 K=0,9 IF(KOLUMN(K).NE.0) THEN IF((K+1)*N1N2N3.GT.MRAM) THEN C GRDPTS-06 CALL ERROR('GRDPTS-06: 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 for each given grid. C You may wish to increase the dimension MRAM in file C ram.inc. END IF C Reading grid values: CALL RARRAY(LU,FGRD(K),'FORMATTED',.TRUE.,UNDEF,N1N2N3, * RAM(K*N1N2N3+1)) END IF 19 CONTINUE IF(FPTS.NE.' ') THEN OPEN(LU,FILE=FPTS) WRITE(LU,'(A)') ' /' FORMA1(1:10)='(A,I6.6,A,' ENDIF IF(FLIN.NE.' ') THEN OPEN(LU2,FILE=FLIN) WRITE(LU2,'(A)') ' /' FORMA2(1:15)='(A,I3.3,I3.3,A,' FORMA3(1:1)='(' ENDIF 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 ((I1.EQ.0).AND.(FLIN.NE.' ')) THEN CALL FORM2(3,X,X,FORMA2(16:15+8*3)) WRITE(LU2,FORMA2) * '''',I2+1,I3+1,''' ',X1,(' ',X(J4),J4=2,3),' /' ENDIF LWRITE=.TRUE. DO 20 K=0,9 IF(KOLUMN(K).GT.0) THEN IF(RAM(K*N1N2N3+I).NE.UNDEF) THEN X(KOLUMN(K))=RAM(K*N1N2N3+I) IF(K.EQ.0) THEN IRAM(I)=N END IF ELSE IRAM(I)=0 LWRITE=.FALSE. END IF ELSE IF(KOLUMN(K).LT.0) THEN IF(RAM(-K*N1N2N3+I).NE.UNDEF) THEN X(-KOLUMN(K))=X(-KOLUMN(K))+RAM(-K*N1N2N3+I) IF(K.EQ.0) THEN IRAM(I)=N END IF ELSE IRAM(I)=0 LWRITE=.FALSE. END IF END IF 20 CONTINUE IF(LWRITE) THEN C Writing: IF(FPTS.NE.' ') THEN CALL FORM2(NCOL,X,X,FORMA1(11:10+8*NCOL)) WRITE(LU,FORMA1) * '''',I,''' ',X1,(' ',X(J4),J4=2,NCOL),' /' ENDIF IF(FLIN.NE.' ') THEN CALL FORM2(NCOL,X,X,FORMA3(2:1+8*NCOL)) WRITE(LU2,FORMA3) * X1,(' ',X(J4),J4=2,NCOL),' /' ENDIF N=N+1 END IF IF ((I1.EQ.N1-1).AND.(FLIN.NE.' ')) THEN WRITE(LU2,'(A)') ' /' ENDIF 21 CONTINUE 22 CONTINUE 23 CONTINUE IF(FPTS.NE.' ') THEN WRITE(LU,'(A)') ' /' CLOSE(LU) ENDIF IF(FLIN.NE.' ') THEN WRITE(LU2,'(A)') ' /' CLOSE(LU2) ENDIF 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(KCOL.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(KCOL.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(KCOL.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 00000066604 11023416420 012651 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: 6.00 C Date: 2006, June 12 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 initial distribution before wavenumber filtering: C RANDIS='string'... Character specifying the distribution: C RANDIS='U' or RANDIS='u': Uniform distribution between C -0.5 and 0.5. C RANDIS='G' or RANDIS='g': Gaussian distribution. C Default: RANDIS='U' 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 Default: CTYPE='D' 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. 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,RANDIS*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 RSEP3T('RANDIS',RANDIS,'U') 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, RANDIS, 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,RANDIS, 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, RANDIS, 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 IF (RANDIS.EQ.'U'.OR.RANDIS.EQ.'u') THEN DO 100 I = 1, NX2*NY2 * WORK(I) = CMPLX(RAN2(ISEED)-.5, 0.) WORK(I) = CMPLX(RAN3(ISEED)-.5, 0.) 100 CONTINUE C C Gaussian distribution ELSE DO 111 I = 1, NX2*NY2, 2 * WORK(I) = CMPLX(RAN2(ISEED)-.5, 0.) 110 CONTINUE V1 = 2.*RAN3(ISEED)-1. V2 = 2.*RAN3(ISEED)-1. VV = V1*V1+V2*V2 IF (VV.GE.1.) GO TO 110 VV = SQRT(-2.*ALOG(VV)/VV) WORK(I) = CMPLX(V1*VV, 0.) IF (I.LT.NX2*NY2) THEN WORK(I+1) = CMPLX(V2*VV, 0.) END IF 111 CONTINUE ENDIF 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 00000014272 11023416420 012415 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: 6.00 C Date: 2006, June 9 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 specifying the distribution: C RANDIS='string'... Character specifying the distribution: C RANDIS='U' or RANDIS='u': Uniform distribution between C -0.5 and 0.5. C RANDIS='G' or RANDIS='g': Gaussian distribution. C Default: RANDIS='U' 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C 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 C ran3.for of Numerical Recipes. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C CHARACTER*80 FILSEP,FILOUT CHARACTER*1 RANDIS 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 distribution: CALL RSEP3T('RANDIS',RANDIS,'U') C Reading numerical constant ISEED: CALL RSEP3I('ISEED',ISEED,-1) C C Random numbers: C Uniform distribution IF (RANDIS.EQ.'U'.OR.RANDIS.EQ.'u') THEN DO 10, I1=1,N1N2N3 RAM(I1)=RAN3(ISEED)-0.5 10 CONTINUE ELSE IF (RANDIS.EQ.'G'.OR.RANDIS.EQ.'g') THEN C Gaussian distribution DO 21, I1=1,N1N2N3,2 20 CONTINUE V1=2.*RAN3(ISEED)-1. V2=2.*RAN3(ISEED)-1. VV=V1*V1+V2*V2 IF(VV.GE.1.) GO TO 20 VV=SQRT(-2.*ALOG(VV)/VV) RAM(I1)=V1*VV IF (I.LT.N1N2N3) THEN RAM(I1+1)=V2*VV END IF 21 CONTINUE ELSE C GRDRAN-03 CALL ERROR('GRDRAN-03: Unknown distribution.') C Check the value of parameter RANDIS. ENDIF 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 00000017612 11023416420 012611 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. 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 C 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 00000036375 11023416420 012255 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: 6.20 C Date: 2008, June 10 C C Coded by Karel Zacek C Department of Geophysics, Charles University Prague 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 Defaults: 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 Defaults: O1=0., O2=0., O3=0. C D1=real... Grid interval along the X1 axis. C Default: D1=1. C D2=real... Grid interval along the X2 axis. C Default: D2=1. C D3=real... Grid interval along the X3 axis. C Default: D3=1. 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 Defaults: N10=1, N20=1, N30=1, O10=0., O20=0., O30=0., C D10=1., D20=1., D30=1. 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 Optional parameters specifying the form of the real-valued quantities C written to the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals in one line of the C output file. See the description in file C forms.for. 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,N1N2N3,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) REAL E,C,S 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(LU1,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. C If possible, increase dimension MRAM in include file C 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.) DO 2 J=1,3 DO 1 I=1,J IF(I.NE.J) THEN AR2(I,J)=2.*AR2(I,J) AI2(I,J)=2.*AI2(I,J) TR2(I,J)=2.*TR2(I,J) TI2(I,J)=2.*TI2(I,J) END IF 1 CONTINUE 2 CONTINUE DO 5 K=1,3 DO 4 J=1,K DO 3 I=1,J IF(I.NE.J.AND.J.NE.K.AND.K.NE.I) THEN AR3(I,J,K)=6.*AR3(I,J,K) AI3(I,J,K)=6.*AI3(I,J,K) TR3(I,J,K)=6.*TR3(I,J,K) TI3(I,J,K)=6.*TI3(I,J,K) ELSE IF(I.NE.J.OR.J.NE.K.OR.K.NE.I) THEN AR3(I,J,K)=2.*AR3(I,J,K) AI3(I,J,K)=2.*AI3(I,J,K) TR3(I,J,K)=2.*TR3(I,J,K) TI3(I,J,K)=2.*TI3(I,J,K) END IF 3 CONTINUE 4 CONTINUE 5 CONTINUE 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 E=EXP(TR) C=COS(TI) S=SIN(TI) FR=(AR*C-AI*S)*E FI=(AR*S+AI*C)*E L=L+1 RAM(L)=FR RAM(N1N2N3+L)=FI C End of calculation at one gridpoint 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 00000020612 11023416420 012757 0 ustar bulant bulant C
C Program GRDTRANS to transpose the coordinate axes of the gridded data C C Version: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C EXTERNAL UARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FSEP,FGRD1,FGRD2 INTEGER LU REAL UNDEF PARAMETER (LU=1) 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 UNDEF=UARRAY() 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 00000037420 11023416420 012441 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 C 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file 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======================================================================= Cgse2segy.for 0100666 0000765 0000765 00000067254 11024140020 012667 0 ustar bulant bulant C
C Program GSE2SEGY converts seismograms stored in the GSE data exchange C format to SEGY format. Trace Data sample values are written in C 32-bit IEEE floating-point format. This format was added by C SEGY revision 1 (Digital tape standards (2004). Society of C Exploration Geophysicists). C This version of program GSE2SEGY writes only limited number C of SEGY reel and trace header parameters. C C Part of code is taken from sp.for. C C Version: 6.20 C Date: 2008, June 12 C C Assembled and coded by: Vaclav Bucha C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: bucha@seis.karlov.mff.cuni.cz C C....................................................................... C C Attention: Functionality of program GSE2SEGY is strongly affected by C the Fortran compiler and by the options of the compiler. C Program GSE2SEGY can work only if the compiler supports unformatted C direct-access files "without headers". C Program GSE2SEGY uses INTEGER*2 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 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 converted. 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 SRC='string'... String with the name of the input data file C with the name(s) and coordinates of the source(s). 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 The source names cannot be longer than 6 characters. C File SRC 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 source 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 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 Description of file REC C Default: REC=' ' C Names of output files: C FISEGY='string'... String with the name of the output SEGY file. C Default: FISEGY='ss.sgy' C Component selection: C KOMP=integer... Selected component of the GSE seismograms C that will be converted to output SEGY file. C Default: KOMP=1 C SEGY parameters: C NTRACE=integer... Number of data traces per record (inludes dummy C and zero traces inserted to fill out the record C or common depth point). C Default: NTRACE=1 C NSAMPL=integer... Number of samples per data trace (for this reel C of data). C Default: NSAMPL=1 C SINTER=real... Sample interval in microseconds (for this reel C of data). C Default: SINTER=1. C ISFORM=integer... Data sample format code. C Default: ISFORM=1 (floating point (4 bytes)) C ICDPF=integer... CDP fold (expected number of data traces per CDP C ensemble). C Default: ICDPF=1 C....................................................................... C C SEGY format specification according to C Barry, K.M, Cavers, D.A. and Kneale, C.W. (1975): C Recommended standards for digital tape formats. C Geophysics, 40, no. 02, 344-352. C (1) Reel identification header (3600 bytes) C (1.1) Part 1, the EBCDIC card image block (3200 bytes - 40 cards) C The EBCDIC part of the reel header describes the data C from a line of shotpoints in a fixed specified format C consisting of 40 card images with each image containing C 80 bytes. All unused card image characters are EBCDIC C Blank. Card image numbers 23 through 39 are unassigned C for optional use. Each card image should contain the C character C in the first card column. Each 80 bytes would C yield one line of format print. C (1.2) Part 2, the binary coded block (400 bytes) C The binary coded section of the reel header consists C of 400 bytes of information common to the seismic data C on the related reel. There are 60 bytes assigned; C 340 are unassigned for optional use. C BINARY CODE - Right Justified C Byte Numbers: Description: C 3201-3204 Job identification number. C 3205-3208 * Line number (only one line per reel). C 3209-3212 * Reel number. C 3213-3214 * Number of data traces per record (inludes dummy C and zero traces inserted to fill out the record C or common depth point). C 3215-3216 * Number of auxiliary traces per record (includes C sweep, timing, gain, sync and all other non-data C traces). C 3217-3218 * Sample interval in microseconds (for this reel C of data). C 3219-3220 Sample interval in microseconds (for original C field recording). C 3221-3222 * Number of samples per data trace (for this reel C of data). C 3223-3224 Number of samples per data trace (for original C field recording). C 3225-3226 * Data sample format code: C 1=floating point (4 bytes) 3=fixed point (2 bytes) C 2=fixed point (4 bytes) 4=fixed point w/gain C code (4 bytes) C Auxiliary traces use the same number of bytes C per sample. C 3227-3228 * CDP fold (expected number of data traces per CDP C ensemble). C C 3229-3230 Trace sorting code: C 1=as recorded (no sorting) 3=single fold continuous C profile C 2=CDP ensemble 4=horizontally stacked C 3231-3232 Vertical sum code: 1=no sum, 2=two sum,..., C N=N sum (N=32767) C 3233-3234 Sweep frequency at start. C 3235-3236 Sweep frequency at end. C 3237-3238 Sweep length (ms). C 3239-3240 Sweep type code: 1=linear 3=exponential C 2=parabolic 4other C 3241-3242 Trace number of sweep channel. C 3243-3244 Sweep trace taper length in ms at start if tapered C (the taper starts at zero time and is effective C for this length). C 3245-3246 Sweep trace taper length in ms at end (the ending C taper starts at sweep length minus the taper C length at end). C 3247-3248 Taper type: 1=linear 3=other C 2=cos(exp2) C 3249-3250 Correlated data traces: 1=no 2=yes C 3251-3252 Binary gain recovered: 1=yes 2=no C 3253-3254 Amplitude recovery method: C 1=none 3=AGC C 2=spherical divergence 4=other C 3255-3256 * Measurement system: 1=meters 2=feet C 3257-3258 Impulse signal polarity: C 1=Increase in pressure or upward geophone case C movement gives negative number on tape. C 2=Increase in pressure or upward geophone case C movement gives positive number on tape. C 3259-3260 Vibratory polarity code. C 3261-3600 Unassigned - for optional information. C C * Strongly recommended that this information always be recorded. C C (2) Trace data block C (2.1) Trace identification header (240 bytes) C Trace header is written in binary code C Byte numbers: Description: C 1-4 * Trace sequence number within line - numbers C continue to increase if additional reels are C required on same line. C 5-8 Trace sequence number within reel - each reel C starts with trace number one. C 9-12 * Original field record number. C 13-16 * Trace number within the original field record. C 17-20 Energy source point number - used when more than C one record occurs at the same effective surface C location. C 21-24 CDP ensemble number. C 25-28 Trace number within the CDP ensemble - each C ensemble starts with trace number one. C 29-30 * Trace identification code: C 1=seismic data 4=time break 7=timing C 2=dead 5=uphole 8=water break C 3=dummy 6=sweep 9..N=optional use C 31-32 Number of vertically summed traces yielding this C trace. (1 is one trace, 2 is two stacked C traces, etc.) C 33-34 Number of horizontally summed traces yielding this C trace. (1 is one trace, 2 is two stacked C traces, etc.) C 35-36 Data use: 1=production. 2=test. C 37-40 Distance from source point to receiver group C (negative if opposite to direction in which line C is shot). C 41-44 Receiver group elevation; all elevations above sea C level are positive and below sea level are negative. C 45-48 Surface elevation at source. C 49-52 Source depth below surface (a positive number). C 53-56 Datum elevation at receiver group. C 57-60 Datum elevation at source. C 61-64 Water depth at source. C 65-68 Water depth at group. C 69-70 Scaler to be applied to all elevations and depths C specified in bytes 41-68 to give the real value. C Scaler=1,+/-10,+/-100,+/-1000, or +/-10000. C If positive, scaler is used as a multiplier; C if negative, scaler is used as a divisor. C 71-72 Scaler to be applied to all coordinates C specified in bytes 73-88 to give the real value. C Scaler=1,+/-10,+/-100,+/-1000, or +/-10000. C If positive, scaler is used as a multiplier; C if negative, scaler is used as a divisor. C 73-76 Source coordinate -X. | If the coordinate units are C | in seconds of arc, the X C | values represent longitude C 77-80 Source coordinate -Y. | and the Y values latitude. C | A positive value designates C | the number of seconds east C 81-84 Group coordinate -X. | of Greenwich Meridian or C | north of the equator and C | a negative value designates C 85-88 Group coordinate -Y. | the number of seconds south C | or west. C 89-90 Coordinate units:1=length (meters or feet). C 2=seconds of arc. C 91-92 Weathering velocity. C 93-94 Subweathering velocity. C 95-96 Uphole time at source. C 97-98 Uphole time at group. C 99-100 Source static correction. C 101-102 Group static correction. C 103-104 Total static applied. (Zero if no static has been C applied.) C 105-106 Lag time A. Time in ms between end of 240-byte trace C identification header and time break. Positive if C time break occurs before end of header. Time break C is defined as the initiation pulse which may be C recorded on an auxiliary trace or as otherwise C specified by the recording system. C 107-108 Lag time B. Time in ms between time break and the C initiation time of the energy source. May be C positive or negative. C 109-110 Delay recording time. Time in ms between initiation C time of energy source and time when recording of C data samples begins. (For deep water work if data C recording does not start at zero time.) C 111-112 Mute time--start. C 113-114 Mute time--end. C 115-116 * Number of samples in this trace. C 117-118 * Sample interval in microseconds for this trace. C 119-120 Gain type of field instruments: 1=fixed, 2=binary, C 3=floating point, 4...N=optional use. C 121-122 Instrument gain constant. C 123-124 Instrument early or initial gain (db). C 125-126 Correlated: 1=no, 2=yes. C 127-128 Sweep frequency at start. C 129-130 Sweep frequency at end. C 131-132 Sweep length in ms. C 133-134 Sweep type: 1=linear, 2=parabolic, 3=exponential, C 4=other. C 135-136 Sweep trace taper length at start in ms. C 137-138 Sweep trace taper length at end in ms. C 139-140 Taper type: 1=linear, 2=cos(exp2), 3=other. C 141-142 Alias filter frequency, if used. C 143-144 Alias filter slope. C 145-146 Notch filter frequency, if used. C 147-148 Notch filter slope. C 149-150 Low cut frequency, if used. C 151-152 High cut frequency, if used. C 153-154 Low cut slope. C 155-156 High cut slope. C 157-158 Year data recorded. C 159-160 Day of year. C 161-162 Hour of day (24 hour clock). C 163-164 Minute of hour. C 165-166 Second of minute. C 167-168 Time basis code: 1=local, 2=GMT, 3=other. C 169-170 Trace weighting factor--defined as 2(exp-N) volts C for the least significant bit. (N=0, 1, ... 32767.) C 171-172 Geophone group number of roll switch position one. C 173-174 Geophone group number of trace number one within C original field record. C 175-176 Geophone group number of last trace within original C field record. C 177-178 Gap size (total number of groups dropped). C 179-180 Overtravel associated with taper at beginning or C end of line: 1=down (or behind), 2=up (or ahead). C 181-240 Unassigned--for optional information. C C * Strongly recommended that this information always be recorded. C C (2.2) Trace data samples C Trace data samples can be written in one of four data sample C formats: C 32 bit floating point format - in which each data value of C a seismic channel is recorded in four successive bytes, C in IBM compatible floating point notation as defined in IBM C Form GA 22-6821. C 32 bit fixed point - each data value of a seismic channel is C recorded in four successive bytes. C 16 bit fixed point - each data value of a seismic channel is C recorded in two successive bytes. C 32 bit fixed point format with gain values. C In all four data formats, the channel or trace data should C represent the absolute input voltage at the recording C instrument. C C....................................................................... C C This Fortran 77 file consists of the following external procedures: C GSE2SEGY... Main program to read and plot the seismograms. C GSE2SEGY 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 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 PARAMETER (LU=1) CHARACTER*80 FILSEP,FILSRC,FILREC,FISEGY CHARACTER*80 FILESS(0:9) C C Parameters and small working arrays: INTEGER ISS,ISP 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 Indices of the sets of SEP parameters INTEGER ISEP,IOLD C C Lists of point coordinates, sources and receivers: C INTEGER NSRC,NREC C DATA FILESS/10*' '/ C C SEGY INTEGER NUMS,LUSEGY PARAMETER (NUMS=9000,LUSEGY=3) CHARACTER*80 RIHE(40) INTEGER*2 RIHB(200),TIH2(120) INTEGER TIH(60) INTEGER NTRACE,NSAMPL,ICDPF,ISFORM REAL TDS(NUMS) REAL SINTER EQUIVALENCE (TIH,TIH2) C C....................................................................... C C Reading name of SEP file with input data: FILSEP=' ' WRITE(*,'(A)') '+GSE2SEGY: Enter input filename: ' READ(*,*) FILSEP IF (FILSEP.EQ.' ') THEN C GSE2SEGY-01 CALL ERROR('GSE2SEGY-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)') '+GSE2SEGY: Working... ' C C Defining index ISEP of the working set of SEP parameters: ISEP=0 CALL SSEP(ISEP,IOLD) CALL SSEP(IOLD,ISEP) C C Output SEGY filename, seismogram component: CALL RSEP3T('FISEGY',FISEGY,'ss.sgy') CALL RSEP3I('KOMP',KOMP,1) C C SEGY reel identification header C Part 1 - the EBCDIC card image block (3200 bytes - 40 cards) RIHE(1)(1:42)='SEGY file written by program gse2segy.for' C Part 2 - the binary coded block (400 bytes) CALL RSEP3I('NTRACE',NTRACE,1) CALL RSEP3I('NSAMPL',NSAMPL,1) CALL RSEP3R('SINTER',SINTER,1.) CALL RSEP3I('ISFORM',ISFORM,1) CALL RSEP3I('ICDPF',ICDPF,1) IF(NSAMPL.GT.NUMS) THEN WRITE(*,*)'NSAMPL=',NSAMPL,' NUMS=',NUMS C GSE2SEGY-02 CALL ERROR * ('GSE2SEGY-02: NSAMPL is greater then NUMS. Increase the value *of NUMS in file gse2segy.for.') END IF RIHB(7)=NTRACE RIHB(9)=SINTER*1000. RIHB(10)=SINTER*1000. RIHB(11)=NSAMPL RIHB(12)=NSAMPL RIHB(13)=ISFORM RIHB(14)=ICDPF OPEN(LUSEGY,FILE=FISEGY,FORM='UNFORMATTED',ACCESS='DIRECT', & RECL=1) C Write EBCDIC card image block (3200 bytes - 40 cards) DO 1 I=1,40 DO 2 J=1,80 WRITE(LUSEGY,REC=(I-1)*80+J) RIHE(I)(J:J) 2 CONTINUE 1 CONTINUE CLOSE(LUSEGY) C Write binary coded block (400 bytes) OPEN(LUSEGY,FILE=FISEGY,FORM='UNFORMATTED',ACCESS='DIRECT', & RECL=2,STATUS='OLD') DO 3 J=1,200 WRITE(LUSEGY,REC=1600+J) RIHB(J) 3 CONTINUE CLOSE(LUSEGY) C C Input and output filenames: CALL RSEP3T('SS' ,FILESS(0),'ss.gse') ISS0=0 C C Reading lists of sources and receivers: 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=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 GSE2SEGY-05 CALL ERROR('GSE2SEGY-05: 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 GSE2SEGY-03 CALL ERROR * ('GSE2SEGY-03: Array dimension MPTS small for sources') 14 CONTINUE NSRC=I-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=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 GSE2SEGY-06 CALL ERROR * ('GSE2SEGY-06: 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 GSE2SEGY-04 CALL ERROR * ('GSE2SEGY-04: Array dimension MPTS small for points') 16 CONTINUE NREC=I-NSRC-1 RECNUM=FLOAT(NREC) CLOSE(LU) END IF C C Loop for GSE files ISS=0 IF(FILESS(ISS).NE.' ') THEN C Opening input GSE file with the seismograms: OPEN(LU,FILE=FILESS(ISS),STATUS='OLD') CALL RGSE1(LU,TEXT) C C Loop for seismograms ITR=1 IREC=0 40 CONTINUE 41 CONTINUE C C Selecting the component: 42 CONTINUE ISS1=ISS0 CALL RGSE2 * (LU,NAMREC,CHAN,I,X1R,X2R,X3R,T0,TD,NSS,MSS,RAM) IF(NSS.LE.-1) THEN C End of the GSE file GO TO 80 END IF IF(I.NE.KOMP) GO TO 42 C C Selecting the receiver: IF(FILREC.EQ.' ') THEN IREC=IREC+1 ELSE C Loop for receivers DO 51 I=NSRC+1,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-NSRC GO TO 52 END IF 51 CONTINUE GO TO 41 END IF 52 CONTINUE C C Reading the source information: ISEP=-ISEP CALL SSEP(ISEP,IOLD) 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.) CALL SSEP(IOLD,ISEP) C C Selecting the source: IF(FILSRC.NE.' ') THEN IF(NAMSRC.EQ.' ') THEN I0=MSS X1S=RAM(I0+1) X2S=RAM(I0+2) X3S=RAM(I0+3) ELSE C Loop for sources DO 55 I=1,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 Determine first sample of seismogram IF(T0.GT.0.) THEN IZERO=T0/TD C Add leading zeros DO 70 I=1,IZERO TDS(I)=0. 70 CONTINUE ELSE IZERO=T0/TD END IF C Add seismogram IF(IZERO+NSS.GT.NSAMPL) THEN IAUX=IZERO+NSS WRITE(*,*)'GSE samples=',IAUX,' NSAMPL=',NSAMPL C GSE2SEGY-07 CALL ERROR * ('GSE2SEGY-07: Number of GSE samples is greater then NSAMPL. *Increase the value of NSAMPL in history file.') END IF IF(T0.GT.0.) THEN DO 72 I=1,NSS TDS(IZERO+I)=RAM(I) 72 CONTINUE C Add trailing zeros DO 74 I=IZERO+NSS+1,NSAMPL TDS(I)=0. 74 CONTINUE ELSE C Add seismogram DO 76 I=1,NSS TDS(I)=RAM(I-IZERO) 76 CONTINUE C Add trailing zeros DO 78 I=NSS+1,NSAMPL TDS(I)=0. 78 CONTINUE END IF C C SEGY trace data block OPEN(LUSEGY,FILE=FISEGY,FORM='UNFORMATTED', & ACCESS='DIRECT',RECL=4,STATUS='OLD') C Trace identification header (240 bytes) TIH(3)=1 TIH(4)=ITR TIH2(58)=NSAMPL TIH2(59)=SINTER*1000. DO 82 K=1,60 WRITE(LUSEGY,REC=900+(ITR-1)*(NSAMPL+60)+K) TIH(K) 82 CONTINUE C Seismic trace data DO 84 J=1,NSAMPL WRITE(LUSEGY,REC=960+(ITR-1)*(NSAMPL+60)+J) TDS(J) 84 CONTINUE CLOSE(LUSEGY) C ITR=ITR+1 GO TO 40 80 CONTINUE C End of loop for receivers C C Closing GSE file CLOSE(LU) END IF C End of loop for GSE files C WRITE(*,'(A)') '+GSE2SEGY: Done. ' STOP 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 C C======================================================================= Cgse.for 0100666 0000765 0000765 00000105110 11023416420 011706 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, C subroutine WSEPR C may be called to generate string containing 2 spaces followed C 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 C values of the real-valued parameters may be obtained by the C invocations of subroutine C 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======================================================================= Chg.for 0100666 0000765 0000765 00000030610 11021432020 011520 0 ustar bulant bulant C
C Subroutine file 'hg.for' to calculate some hypergeometric functions C C Version: 6.20 C Date: 2008, June 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 HG2F1...Subroutine designed to calculate hypergeometric function C 2F1(A,B;C;X). C HG2F1 C HGF1... Subroutine designed to calculate hypergeometric function C F1(A,B1,1,C;X1,X2). C HGF1 C HGF2... Subroutine designed to calculate hypergeometric function C F2(A,B1,1,C1,C2;X1,X2). C HGF2 C HGFM2...Subroutine designed to calculate modified hypergeometric C function F~2(A,B1,1,C1,1;X1,X2). C HGFM2 C C======================================================================= C C C SUBROUTINE HG2F1(A,B,C,X,ERR,F) REAL A,B,C,X,ERR,F C C Subroutine designed to calculate hypergeometric function 2F1(A,B;C;X). C C Input: C A,B,C.. Parameters of hypergeometric function 2F1(A,B;C;X). C The parameters are assumed to be positive. C X... Variable of hypergeometric function 2F1(A,B;C;X). C The subroutine is designed for non-negative X sufficiently C smaller than 1. C ERR... Absolute error of the output value. C Output: C F... Value of hypergeometric function 2F1(A,B;C;X). C C Date: 2008, June 3 C Coded by: Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I REAL AA,BB,CC,DD,XX,ERR1,RATIO,TERM,SUM C C....................................................................... C C Check of input values IF(A.LE.0..OR.B.LE.0..OR.C.LE.0..OR.X.LT.0..OR.X.GE.1. * .OR.ERR.LE.0.) THEN C HG-01 CALL ERROR('HG-01: Wrong input values in HG2F1') END IF C C Summing the Gauss series: AA=A BB=B CC=C DD=1. XX=X ERR1=ERR C Zero and first terms TERM=XX*AA*BB/CC SUM=1.+TERM C Second and subsequent terms DO 1 I=2,1000 AA=AA+1. BB=BB+1. CC=CC+1. DD=DD+1. RATIO=XX*AA*BB/CC/DD IF(RATIO.EQ.0.) THEN F=SUM RETURN END IF TERM=TERM*RATIO SUM=SUM+TERM IF(TERM.LT.ERR1/RATIO-ERR1) THEN F=SUM RETURN END IF 1 CONTINUE C C HG-02 CALL ERROR('HG-02: Convergence failure in HG2F1') RETURN END C C======================================================================= C C C SUBROUTINE HGF1(A,B1,C,X1,X2,ERR,F) REAL A,B1,C,X1,X2,ERR,F C C Subroutine designed to calculate hypergeometric function C F1(A,B1,1,C;X1,X2). C C Input: C A,B1,C..Parameters of hypergeometric function F1(A,B1,1,C;X1,X2). C The parameters are assumed to be positive. C X1,X2...Variables of hypergeometric function F1(A,B1,1,C;X1,X2). C The subroutine is designed for non-negative X1 and X2 C sufficiently smaller than 1. C ERR... Absolute error of the output value. C Output: C F... Value of hypergeometric function F1(A,B1,1,C;X1,X2). C C Date: 2008, June 3 C Coded by: Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I1,I2 REAL AA1,BB1,CC1,DD1,AA2,CC2,XX1,XX2,ERR1 REAL RATIO1,RATIO2,TERM1,TERM2,SUM1,SUM2 C C....................................................................... C C Check of input values IF(A.LE.0..OR.B1.LE.0..OR.C.LE.0..OR.X1.LT.0..OR.X1.GE.1. * .OR.ERR.LE.0..OR.X2.LT.0..OR.X2.GE.1.) THEN C HG-03 CALL ERROR('HG-03: Wrong input values in HGF1') END IF IF(X1.EQ.0.) THEN CALL HG2F1(A,1.,C,X2,ERR,F) RETURN END IF IF(X2.EQ.0.) THEN CALL HG2F1(A,B1,C,X1,ERR,F) RETURN END IF C C Estimating the number of iterations with respect to X1 ERR1=ALOG((1.-X1)*ERR)/ALOG(X1) C Error for iterations with respect to X2 ERR1=ERR/(AMAX1(0.,ERR1)+1.) C C Summing the Gauss series: AA1=A BB1=B1 CC1=C DD1=1. XX1=X1 XX2=X2 TERM1=1. SUM1=0. C Loop over powers in X1 DO 11 I1=0,1000 AA2=AA1 CC2=CC1 C Zero and first terms with respect to X2 TERM2=TERM1*XX2*AA2/CC2 SUM2=TERM1+TERM2 C Second and subsequent terms with respect to X2 DO 2 I2=2,1000 AA2=AA2+1. CC2=CC2+1. RATIO2=XX2*AA2/CC2 IF(RATIO2.EQ.0.) THEN GO TO 10 END IF TERM2=TERM2*RATIO2 SUM2=SUM2+TERM2 IF(TERM2.LT.ERR1/RATIO2-ERR1) THEN GO TO 10 END IF 2 CONTINUE C HG-04 CALL ERROR('HG-04: Convergence failure in inner loop in HGF1') 10 CONTINUE SUM1=SUM1+SUM2 RATIO1=XX1*AA1*BB1/CC1/DD1 IF(RATIO1.EQ.0.) THEN F=SUM1 RETURN END IF IF(SUM2.LT.ERR1/RATIO1-ERR1) THEN F=SUM1 RETURN END IF C Values for the next iteration with respect to X1 TERM1=TERM1*RATIO1 AA1=AA1+1. BB1=BB1+1. CC1=CC1+1. DD1=DD1+1. 11 CONTINUE C C HG-05 CALL ERROR('HG-05: Convergence failure in outer loop in HGF1') RETURN END C C======================================================================= C C C SUBROUTINE HGF2(A,B1,C1,C2,X1,X2,ERR,F) REAL A,B1,C1,C2,X1,X2,ERR,F C C Subroutine designed to calculate hypergeometric function C F2(A,B1,1,C1,C2;X1,X2). C C Input: C A,B1,C1,C2... Parameters of hypergeometric function C F2(A,B1,1,C1,C2;X1,X2). C The parameters are assumed to be positive. C X1,X2...Variables of hypergeometric function C F2(A,B1,1,C1,C2;X1,X2). C The subroutine is designed for non-negative X1 and X2 C with X1+X2 sufficiently smaller than 1. C ERR... Absolute error of the output value. C Output: C F... Value of hypergeometric function F2(A,B1,1,C1,C2;X1,X2). C C Date: 2008, June 3 C Coded by: Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I1,I2 REAL AA1,BB1,CC1,DD1,AA2,CC2,XX1,XX2,ERR1 REAL RATIO1,RATIO2,TERM1,TERM2,SUM1,SUM2 C C....................................................................... C C Check of input values IF(A.LE.0..OR.B1.LE.0..OR.C1.LE.0..OR.X1.LT.0..OR.X1+X2.GE.1. * .OR.ERR.LE.0..OR.C2.LE.0..OR.X2.LT.0.) THEN C HG-06 CALL ERROR('HG-06: Wrong input values in HGF2') END IF IF(X1.EQ.0.) THEN CALL HG2F1(A,1.,C2,X2,ERR,F) RETURN END IF IF(X2.EQ.0.) THEN CALL HG2F1(A,B1,C1,X1,ERR,F) RETURN END IF C C Estimating the number of iterations with respect to X1 ERR1=ALOG((1.-X1-X2)*ERR)/ALOG(X1+X2) C Error for iterations with respect to X2 ERR1=ERR/(AMAX1(0.,ERR1)+1.) C C Summing the Gauss series: AA1=A BB1=B1 CC1=C1 DD1=1. XX1=X1 XX2=X2 TERM1=1. SUM1=0. C Loop over powers in X1 DO 11 I1=0,1000 AA2=AA1 CC2=C2 C Zero and first terms with respect to X2 TERM2=TERM1*XX2*AA2/CC2 SUM2=TERM1+TERM2 C Second and subsequent terms with respect to X2 DO 2 I2=2,1000 AA2=AA2+1. CC2=CC2+1. RATIO2=XX2*AA2/CC2 IF(RATIO2.EQ.0.) THEN GO TO 10 END IF TERM2=TERM2*RATIO2 SUM2=SUM2+TERM2 IF(TERM2.LT.ERR1/RATIO2-ERR1) THEN GO TO 10 END IF 2 CONTINUE C HG-07 CALL ERROR('HG-07: Convergence failure in inner loop in HGF2') 10 CONTINUE SUM1=SUM1+SUM2 RATIO1=XX1*AA1*BB1/CC1/DD1 IF(RATIO1.EQ.0.) THEN F=SUM1 RETURN END IF IF(SUM2.LT.ERR1/RATIO1-ERR1) THEN F=SUM1 RETURN END IF C Values for the next iteration with respect to X1 TERM1=TERM1*RATIO1 AA1=AA1+1. BB1=BB1+1. CC1=CC1+1. DD1=DD1+1. 11 CONTINUE C C HG-08 CALL ERROR('HG-08: Convergence failure in outer loop in HGF2') RETURN END C C======================================================================= C C C SUBROUTINE HGFM2(A,B1,C1,X1,X2,ERR,F) REAL A,B1,C1,X1,X2,ERR,F C C Subroutine designed to calculate modified hypergeometric function C F~2(A,B1,1,C1,1;X1,X2). C C Input: C A,B1,C1... Parameters of modified hypergeometric function C F~2(A,B1,1,C1,1;X1,X2). C Parameters A and C1 are assumed to be positive, C parameter B1 is assumed to be greater than -1. C X1,X2...Variables of modified hypergeometric function C F~2(A,B1,1,C1,1;X1,X2). C The subroutine is designed for non-negative X1 and X2 C sufficiently smaller than 1. C ERR... Absolute error of the output value. C Output: C F... Value of hypergeometric function F~2(A,B1,1,C1,1;X1,X2). C C Date: 2008, June 3 C Coded by: Ludek Klimes C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I1,I2 REAL AA1,BB1,CC1,DD1,AA2,DD2,XX1,XX2,ERR1 REAL RATIO1,RATIO2,TERM1,TERM2,SUM1,SUM2 C C....................................................................... C C Check of input values IF(A.LE.0..OR.B1.LE.-1..OR.C1.LE.0..OR.X1.LT.0..OR.X1.GE.1. * .OR.ERR.LE.0..OR.X2.LT.0..OR.X2.GE.1.) THEN C HG-09 CALL ERROR('HG-09: Wrong input values in HGFM2') END IF IF(X1.EQ.0.) THEN CALL HG2F1(A,1.,1.,X2,ERR,F) RETURN END IF IF(X2.EQ.0.) THEN CALL HG2F1(A,B1,C1,X1,ERR,F) RETURN END IF C C Estimating the number of iterations with respect to X1 ERR1=ALOG((1.-X1)*ERR)/ALOG(X1) C Error for iterations with respect to X2 ERR1=ERR/(AMAX1(0.,ERR1)+1.) C C Summing the Gauss series: AA1=A BB1=B1 CC1=C1 DD1=1. XX1=X1 XX2=X2 TERM1=1. SUM1=0. C Loop over powers in X1 DO 11 I1=0,1000 AA2=AA1 DD2=DD1 C Zero and first terms with respect to X2 TERM2=TERM1*XX2*AA2/DD2 SUM2=TERM1+TERM2 C Second and subsequent terms with respect to X2 DO 2 I2=2,1000 AA2=AA2+1. DD2=DD2+1. RATIO2=XX2*AA2/DD2 IF(RATIO2.EQ.0.) THEN GO TO 10 END IF TERM2=TERM2*RATIO2 SUM2=SUM2+TERM2 IF(ABS(TERM2).LT.ERR1/RATIO2-ERR1) THEN GO TO 10 END IF 2 CONTINUE C HG-10 CALL ERROR('HG-10: Convergence failure in inner loop in HGFM2') 10 CONTINUE SUM1=SUM1+SUM2 RATIO1=XX1*AA1*BB1/CC1/DD1 IF(RATIO1.EQ.0.) THEN F=SUM1 RETURN END IF IF(ABS(SUM2).LT.ERR1/RATIO1-ERR1) THEN F=SUM1 RETURN END IF C Values for the next iteration with respect to X1 TERM1=TERM1*RATIO1 AA1=AA1+1. BB1=BB1+1. CC1=CC1+1. DD1=DD1+1. 11 CONTINUE C C HG-11 CALL ERROR('HG-11: Convergence failure in outer loop in HGFM2') RETURN END C C======================================================================= C hsv.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 00000061102 11023416420 012436 0 ustar bulant bulant CC Program INIWRL to initialize a virtual reality description file C C Version: 6.00 C Date: 2006, June 15 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 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,UARRAY REAL UARRAY INTEGER LENGTH C C Filenames and parameters: CHARACTER*80 FILE1,FILE2 INTEGER LU1,LU2 REAL UNDEF PARAMETER (LU1=1,LU2=2) 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 UNDEF=UARRAY() 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 00000011427 11003552420 012417 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 'forms.for' C forms.for INCLUDE 'length.for' C length.for INCLUDE 'wrl.for' C wrl.for C C======================================================================= C C Subroutine file 'length.for' to facilitate string manipulation. C C Version: 6.20 C Date: 2008, April 23 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 UPPER...Subroutine changing a given character string to uppercase. C UPPER C LENGTH..Integer function to determine the length of a string C without trailing blanks. C LENGTH C STRIND..Character function to supplement a given string with C a given index. C STRIND 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 SUBROUTINE UPPER(TEXT) CHARACTER*(*) TEXT C C Subroutine changing a given character string to uppercase. C C Input: C TEXT... A given string. C C Output: C TEXT... The given string converted to uppercase. 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======================================================================= C C CHARACTER*(*) FUNCTION STRIND(STR,IND) CHARACTER*(*) STR INTEGER IND C C Character function to supplement a given string with a given index. C C Input: C STR... Character string. C IND... Non-negative integer. C C Output: C STRIND..String composed of string STR (without trailing blanks) C and of the string representing integer IND (without C leading zeros or blanks). C Examples: STR='abc', IND=0, STRIND='abc0'; C STR='abc', IND=1, STRIND='abc1'; C STR='abc', IND=234, STRIND='abc234'. C C Subroutines and external functions required: EXTERNAL LENGTH INTEGER LENGTH C C Date: 2005, June 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C CHARACTER*4 FORMAT INTEGER I,L C C....................................................................... C STRIND=STR FORMAT='(I0)' L=LENGTH(STR) I=INT(ALOG10(FLOAT(IND)+0.5))+1 FORMAT(3:3)=CHAR(ICHAR('0')+I) WRITE(STRIND(L+1:L+I),FORMAT) IND RETURN END C C======================================================================= Clinden.for 0100666 0000765 0000765 00000022711 11023416420 012406 0 ustar bulant bulant CC Program LINDEN to densify lines C C Version: 6.00 C Date: 2005, November 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 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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, C but must be different from the value of UNDEF. C For the value of UNDEF see function UARRAY of file C forms.for. 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 For the value of UNDEF see function UARRAY of file C forms.for. 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,UARRAY REAL UARRAY INTEGER LENGTH C ERROR ... File C error.for. C RSEP1,RSEP3T,RSEP3I ... File C sep.for. C FORM1 ... File C forms.for. C LENGTH ... File C 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) 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 UNDEF=UARRAY() 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 00000055354 11023416420 012455 0 ustar bulant bulant CC Program LINWRL to convert lines into the Virtual Reality Modeling C Language or GOCAD representation C C Version: 6.10 C Date: 2006, October 10 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....................................................................... 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 C 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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, * UARRAY REAL UARRAY INTEGER LENGTH C C Filenames and parameters: CHARACTER*80 FSEP,FLIN,FIN,FOUT INTEGER LU1,LU2,LU3,IUNDEF,MQ REAL UNDEF PARAMETER (LU1=1,LU2=2,LU3=3,IUNDEF=-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 UNDEF=UARRAY() 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('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 00000000640 11023416420 011740 0 ustar bulant bulantInitializing 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 00000002363 11023416420 011745 0 ustar bulant bulantIncluding 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 00000001334 11023416420 011743 0 ustar bulant bulantFinishing 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)mat.for 0100666 0000765 0000765 00000176403 11024140020 011715 0 ustar bulant bulant CC Subroutine file 'mat.for' with subroutines dealing with matrices. C C Version: 6.20 C Date: 2008, June 12 C C....................................................................... C C This file consists of the following external procedures: C WMATH.. Subroutine designed to write a matrix header file. C WMATH C RMATH.. Subroutine designed to read a matrix header file. C RMATH C WMATD.. Subroutine designed to write a matrix data file. C WMATD C RMATD.. Subroutine designed to read a matrix data file. C RMATD C WMATR.. Auxiliary subroutine to WMATD, designed to write the array C of matrix elements into a file. C WMATR C TMATR...Subroutine to transpose a matrix. C TMATR C SMATRE..Subroutine to extend sparse symmetric or antisymmetric C matrix into sparse general matrix. C SMATRE C GSMATR..Subroutine to change normal (not sparse) matrix into C the sparse matrix. C GSMATR C SGMATR..Subroutine to change sparse matrix into the normal C (not sparse) matrix. C SGMATR C GSMAT...Subroutine to change normal (not sparse) matrix into C the sparse matrix if the matrix is sparser than given C limit. C GSMAT C VELEM...Real function to find the value of an element of a matrix. C NELMAT..Integer function to calculate total number of elements C of a non-sparse matrix. C NELMAT C NSPMAT..Integer function to calculate number of zero elements C of a non-sparse matrix. C NSPMAT C ISYM ...Integer function to assign the integer corresponding C to the symmetry. C ISYM C MSHIFT..Subroutine designed to shift the matrix in memory. C MSHIFT C Subroutines to enable functionality of some programs which C do not use above subroutines directly: 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 C======================================================================= C C Storage of the matrices in the memory: C The matrices are stored in real array RAM of common block RAMC C defined in file ram.inc. C To store integers in this array, integer array IRAM coinciding C with real array RAM is also defined. C Normal (not sparse) matrices: C Normal (dense) matrices are identified by the value of C SPARSE=' ' in the matrix header file. For normal matrices C all values of the matrix are stored columnwise, starting C from the first value of the first column to the last C stored value of the first column, then the second column, C and so on to the value of the last stored element of the C last column. C If the matrix is other than general, only N elements C corresponding to the given symmetry are stored, i.e. for C a symmetric matrix, just elements from the first row to C the diagonal are stored for each column (N=M1*(M1+1)/2); C for a skew matrix, just elements above the diagonal C are stored for each column (N=M1*(M1-1)/2); for a diagonal C matrix, just diagonal elements are stored (N=M1). C Sparse matrices: C Sparse matrices are identified by the value of C SPARSE='CSC'. NELEM is the number of nonzero elements C of the matrix, calculating only the elements corresponding C to the given symmetry, see above. C The first M2 storage locations contain the addresses C of the beginnings of all columns of the matrix. C The nonzero elements of column J of the matrix are thus C stored in the positions from (I)RAM(IRAM(IMAT+J-1)) C to (I)RAM(IRAM(IMAT+J)-1), where IMAT is the address C of the first storage location of the matrix. C The (M2+1)th storage location contains the address in the C array just after the last stored element. This address C may be understood as the address of the beginning of a C fictitious column number M2+1. C Next 2*NELEM storage locations contain the nonzero C elements of the matrix stored columnwise. Each element C occupies two storage locations, the first one containing C index of the row of the element and written in the integer C array, the second one containing the value of the element C and written in the real array. In this form the matrix C occupies 1+M2+2*NELEM storage locations. C C For the description of the forms of the disk files with matrices C and of the parameters describing the matrices in the matrix header C files refer to file forms.htm. C C======================================================================= C C C SUBROUTINE WMATH(LU,FILEH,FILED,M1,M2,SPARSE,NELEM,SYMM,FORM) INTEGER LU,M1,M2,NELEM CHARACTER*(*) FILEH,FILED,SPARSE,SYMM,FORM C C Subroutine designed to write the matrix header file. C C Input: C LU... Logical unit number of the matrix header output file. C The output matrix header file is opened, written, and C closed. C FILEH.. String containing the name of the matrix header file. C The matrix header file has the form of the SEP parameter C file. C If FILEH=' ', no action is done. C FILED.. String containing the name of the matrix data file. C If FILED=' ', default filename is determined and returned. C The default matrix data filename is constructed from the C matrix header filename by either replacing its last C character by '@' if the filename has a three-character C extension, or by adding '@' in other cases. C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C SPARSE... Sparseness of the matrix data file: C SPARSE=' ': Matrix is dense (not sparse). C SPARSE='CSC' (case insensitive): Matrix is a sparse matrix C stored in the compressed column format. C NELEM...Number of nonzero elements of the sparse matrix, C calculating only the elements corresponding to the C symmetry of the matrix. C For SPARSE=' ', NELEM has no meaning and is not used. C SYMM... Symmetry of the matrix data file: C SYMM=' ': General matrix. C SYMM='sym': Symmetric matrix. C SYMM='skew': Skew matrix. C SYMM='diag': Diagonal matrix. C FORM... Form of the matrix data file: C FORM='FORMATTED': Formatted file. C FORM='UNFORMATTED': Unformatted file. C If FORM=' ', default FORM is determined according to the C SEP parameter FORMM and returned. Default for FORMM is C FORMM='FORMATTED'. C C Output: C FILED.. If FILED=' ' on input, default filename is determined C and returned. C Otherwise, the input value of FILED is returned. C FORM... If FORM=' ' on input, default FORM for writing C is determined, converted to uppercase, and returned. C C Input SEP parameter: C FORMM='string'... Form of the matrix data file: C FORMM='FORMATTED': Formatted file. C FORMM='UNFORMATTED': Unformatted file. C Default: FORMM='FORMATTED' C C Subroutines and external functions required: EXTERNAL LENGTH,UPPER,WSEP3I,WSEP3T,RSEP3T INTEGER LENGTH C LENGTH,UPPER ... File 'length.for'. C WSEP3I,WSEP3T,RSEP3T... File 'sep.for'. C C Coded by Ludek Klimes and Petr Bulant C C----------------------------------------------------------------------- C INTEGER L CHARACTER*72 TXTERR C IF(FILEH.EQ.' ') THEN RETURN END IF C C Opening the matrix header file: OPEN(LU,FILE=FILEH,ERR=100) C C Default data file name: IF(FILED.EQ.' ') THEN L=LENGTH(FILEH) IF (L.GE.4) THEN IF (FILEH(L-3:L-3).EQ.'.') THEN L=L-1 ENDIF ENDIF L=L+1 FILED=FILEH FILED(L:L)='@' END IF C C Default form of the data file: IF(FORM.EQ.' ') THEN CALL RSEP3T('FORMM',FORM,'FORMATTED') CALL UPPER(FORM) END IF C C Writing the values of the parameters describing the output matrix: CALL WSEP3T(LU,'IN',FILED) CALL WSEP3I(LU,'M1',M1) CALL WSEP3I(LU,'M2',M2) CALL WSEP3T(LU,'SPARSE',SPARSE) IF(SPARSE.NE.' ') THEN CALL WSEP3I(LU,'NELEM',NELEM) END IF CALL WSEP3T(LU,'SYMMETRY',SYMM) CALL WSEP3T(LU,'FORM',FORM) C CLOSE(LU) RETURN 100 CONTINUE C MAT-01 WRITE(TXTERR,'(A,A,A)') 'MAT-01: Error when opening file ''', *FILEH(1:MIN0(LENGTH(FILEH),37)),'''.' CALL ERROR(TXTERR) END C C======================================================================= C C C SUBROUTINE RMATH(LU,FILEH,FILED,M1,M2,SPARSE,NELEM,SYMM,FORM) INTEGER LU,M1,M2,NELEM CHARACTER*(*) FILEH,FILED,SPARSE,SYMM,FORM C C Subroutine designed to read the matrix header file. C C Input: C LU... Logical unit number of the input matrix header file. C The input matrix header file is opened, read, and C closed. C FILEH.. String containing the name of the matrix header file. C The matrix header file has the form of the SEP parameter C file. C If FILEH=' ', no file is read and defaults are returned. C The input parameters are not altered. C C Output: C FILED.. String containing the name of the matrix data file. C The default matrix data filename is constructed from the C matrix header filename by either replacing its last C character by '@' if the filename has a three-character C extension, or by adding '@' in other cases. C M1... Number of rows of the matrix. Default: M1=1 C M2... Number of columns of the matrix. Default: M2=1 C SPARSE... Sparseness of the matrix data file: C SPARSE=' ': Matrix is dense (not sparse). C SPARSE='CSC': Matrix is a sparse matrix stored in the C compressed column format. C Default: SPARSE=' ' C NELEM...Number of elements of the matrix stored in the matrix C data file. I.e. either the number of nonzero elements C of the sparse matrix, or the number of elements C of dense matrix. C SYMM... Symmetry of the matrix data file: C SYMM=' ': General matrix. C SYMM='sym': Symmetric matrix. C SYMM='skew': Skew matrix. C SYMM='diag': Diagonal matrix. C Default: SYMM=' ' C FORM... Form of the matrix data file: C FORM='FORMATTED': Formatted file. C FORM='UNFORMATTED': Unformatted file. C Default: FORM='FORMATTED' C Note: the values of SPARSE and FORM are converted to uppercase C on output, and the value of SYMM to lowercase, in order to C simplify comparing of the strings in the calling program. C C Subroutines and external functions required: EXTERNAL LENGTH,LOWER,UPPER,SSEP,RSEP1,RSEP3I,RSEP3T,ISYM,NELMAT INTEGER LENGTH,ISYM,NELMAT C LENGTH,LOWER,UPPER ... File 'length.for'. C SSEP,RSEP1,RSEP3I,RSEP3T... File 'sep.for'. C C Coded by Ludek Klimes and Petr Bulant C C----------------------------------------------------------------------- C CHARACTER*80 FILEDD INTEGER L,ISYMM C Indices of the sets of SEP parameters INTEGER ISEP,IOLD,ITMP SAVE ISEP DATA ISEP/0/ C C Switching to a new parameter set and reading the matrix header: CALL SSEP(ISEP,IOLD) CALL RSEP1(LU,FILEH) C C Reading the values of the parameters describing the input matrix: L=LENGTH(FILEH) IF (L.GE.4) THEN IF (FILEH(L-3:L-3).EQ.'.') THEN L=L-1 ENDIF ENDIF L=L+1 FILEDD=FILEH FILEDD(L:L)='@' CALL RSEP3T('IN',FILED,FILEDD) CALL RSEP3I('M1',M1,1) CALL RSEP3I('M2',M2,1) CALL RSEP3T('SPARSE',SPARSE,' ') CALL RSEP3T('SYMMETRY',SYMM,' ') CALL RSEP3T('FORM',FORM,'FORMATTED') C C Converting input strings to lowercase: CALL LOWER(SYMM) CALL UPPER(FORM) CALL UPPER(SPARSE) C C Number NELEM of stored matrix elements: ISYMM=ISYM(SYMM) NELEM=NELMAT(M1,M2,ISYMM) L=NELEM IF(SPARSE.NE.' ') THEN CALL RSEP3I('NELEM',NELEM,L) ENDIF C ISEP=-ISEP CALL SSEP(ISEP,ITMP) CALL SSEP(IOLD,ISEP) RETURN END C C======================================================================= C C C SUBROUTINE WMATD(LU,FILED,M1,M2,SPARSE,NELEM,FORM,IMAT) CHARACTER*(*) FILED,FORM,SPARSE INTEGER LU,M1,M2,NELEM,IMAT C C Subroutine designed to write a given matrix into the matrix data file. C The matrix to be written is assumed to be stored in common block RAMC C of file 'ram.inc'. C C Input: C LU... Logical unit number to be used for the output. C FILED...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 Used only for SPARSE='CSC'. C M2... Number of columns of the matrix. C Used only for SPARSE='CSC'. C SPARSE... Sparseness of the matrix data file: C SPARSE=' ': Matrix is dense (not sparse). C SPARSE='CSC' (case insensitive): Matrix is a sparse matrix C stored in the compressed column format. C NELEM.. Number of elements of the matrix to be written. C FORM... Form of the matrix data file: C FORM='FORMATTED': Formatted file. C FORM='UNFORMATTED': Unformatted file. C IMAT... Address of the first storage location of the matrix C in array RAM (or IRAM) of common block RAMC. C No output. C C The description of storage of matrices in the memory may be found C above. C For description of storage of matrices in disk files refer to file C forms.htm. C C Subroutines and external functions required: EXTERNAL LENGTH,UPPER,WARRAI,WMATR INTEGER LENGTH C LENGTH,UPPER... File 'length.for'. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (RAM,IRAM) C C Coded by Ludek Klimes and Petr Bulant C C----------------------------------------------------------------------- C C Local storage locations: INTEGER O,I1,I2 CHARACTER*72 TXTERR CHARACTER*11 FORMU,SPARSU C O... Position of the first matrix element in (I)RAM. C C....................................................................... C C Form of the file with the matrix, opening the file: FORMU=FORM CALL UPPER(FORMU) IF(FILED.NE.' ') THEN WRITE(*,'(2A)') '+Writing: ',FILED(1:MIN0(LENGTH(FILED),70)) OPEN(LU,FILE=FILED,FORM=FORMU,ERR=100) END IF C C Writing the matrix: O=IMAT SPARSU=SPARSE CALL UPPER(SPARSU) IF(SPARSU.EQ.'CSC') THEN C Rewriting the array of pointers into the disk form: I2=(IMAT-1)+(M2+1)+1 DO 10, I1=IMAT,IMAT+M2 IRAM(I1)=(IRAM(I1)-I2)/2 10 CONTINUE C Writing the pointers: CALL WARRAI(LU,' ',FORMU,.FALSE.,0,.FALSE.,0,M2,IRAM(IMAT+1)) C Rewriting the array of pointers into the memory form: DO 20, I1=IMAT,IMAT+M2 IRAM(I1)=IRAM(I1)*2+I2 20 CONTINUE O=IMAT+M2+1 END IF CALL WMATR(LU,M1,M2,SPARSE,NELEM,FORMU,O) C C Closing output file: IF(FILED.NE.' ') THEN CLOSE(LU) WRITE(*,'(1A)') * '+ ' END IF RETURN 100 CONTINUE C MAT-02 WRITE(TXTERR,'(A,A,A)') 'MAT-02: Error when opening file ''', *FILED(1:MIN0(LENGTH(FILED),37)),'''.' CALL ERROR(TXTERR) END C C======================================================================= C C C SUBROUTINE RMATD(LU,FILED,M2,SPARSE,NELEM,FORM,IMAT) CHARACTER*(*) FILED,FORM,SPARSE INTEGER LU,M2,NELEM,IMAT C C Subroutine designed to read a matrix from the matrix data file C and to store it in common block RAMC of file 'ram.inc'. C C Input: C LU... Logical unit number to be used for the input. C FILED...Name of the matrix data file. If not blank, the file will C be opened and closed. If blank, the file is assumed to be C already open, and will not be closed in this subroutine. C M2... Number of columns of the matrix. C Used only for SPARSE='CSC'. C SPARSE... Sparseness of the matrix data file: C SPARSE=' ': Matrix is dense (not sparse). C SPARSE='CSC' (case insensitive): Matrix is a sparse matrix C stored in the compressed column format. C NELEM.. Number of elements of the matrix to be read. C FORM... Form of the matrix data file: C FORM='FORMATTED': Formatted file. C FORM='UNFORMATTED': Unformatted file. C IMAT... Address of the first storage location in array RAM C (or IRAM) of common block RAMC where to store the matrix. C C No output. C C Subroutines and external functions required: EXTERNAL LENGTH,UPPER,RARRAI,RARRAY INTEGER LENGTH C LENGTH,UPPER... File 'length.for'. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (RAM,IRAM) C C Coded by Ludek Klimes and Petr Bulant C C----------------------------------------------------------------------- C C Local storage locations: INTEGER O,I,I1,I2 CHARACTER*72 TXTERR CHARACTER*11 FORMU,SPARSU C O... Position of the first matrix element in (I)RAM. C C....................................................................... C C Opening the file with matrix data: FORMU=FORM CALL UPPER(FORMU) IF(FILED.NE.' ') THEN WRITE(*,'(2A)') '+Reading: ',FILED(1:MIN0(LENGTH(FILED),70)) OPEN(LU,FILE=FILED,FORM=FORMU,STATUS='OLD',ERR=100) END IF C C Reading the matrix: O=IMAT SPARSU=SPARSE CALL UPPER(SPARSU) IF(SPARSU.EQ.'CSC') THEN C Sparse matrix: C Reading the pointers: IRAM(O)=0 CALL RARRAI(LU,' ',FORMU,.FALSE.,0,M2,IRAM(O+1)) C Rewriting the array of pointers into the memory form: I2=(IMAT-1)+(M2+1)+1 DO 20, I1=IMAT,IMAT+M2 IRAM(I1)=IRAM(I1)*2+I2 20 CONTINUE C Reading the indices and values: O=IMAT+M2+1 IF(FORMU.EQ.'FORMATTED') THEN READ(LU,*) (IRAM(I),RAM(I+1),I=O,O+2*NELEM-1,2) ELSE READ(LU) (IRAM(I),RAM(I+1),I=O,O+2*NELEM-1,2) END IF ELSE CALL RARRAY(LU,' ',FORMU,.FALSE.,0.,NELEM,RAM(O)) END IF C C Closing input file: IF(FILED.NE.' ') THEN CLOSE(LU) WRITE(*,'(1A)') * '+ ' END IF RETURN 100 CONTINUE C MAT-03 WRITE(TXTERR,'(A,A,A)') 'MAT-03: Error when opening file ''', *FILED(1:MIN0(LENGTH(FILED),37)),'''.' CALL ERROR(TXTERR) END C C======================================================================= C C C SUBROUTINE WMATR(LU,M1,M2,SPARSE,NELEM,FORM,IMAT) CHARACTER*(*) SPARSE,FORM INTEGER LU,M1,M2,NELEM,IMAT C C Subroutine designed to write a given array of matrix elements into the C matrix data file. C C Input: C LU... Logical unit number to be used for the output. C The file should be already opened, and is not closed after C writing. C M1... Number of rows of the matrix. C Used only for SPARSE='CSC'. C M2... Number of columns of the matrix. C Used only for SPARSE='CSC'. C SPARSE... Sparseness of the matrix data file: C SPARSE=' ': Matrix is dense (not sparse). C SPARSE='CSC' (case insensitive): Matrix is a sparse matrix C stored in the compressed column format. C NELEM.. Number of matrix elements to be written. C FORM... Form of the matrix data file in lowercase: C FORM='FORMATTED': Formatted file. C FORM='UNFORMATTED': Unformatted file. C IMAT... Address of the first storage location in array RAM C (or IRAM) of common block RAMC where the matrix data C are stored (i.e. first location after pointers for C sparse matrix). C C No output. C C C Input SEP parameter: C NUMLINM=positive integer... Number of the numbers to be written C to each line of the output file. For sparse matrices C number of pairs of row indices and values of matrix C elements to be written to each line. C NUMLINM must be less than 100 (99 at most). C Default: NUMLINM=5 C C Subroutines and external functions required: EXTERNAL UPPER C UPPER... File 'length.for'. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (RAM,IRAM) C C Coded by Ludek Klimes and Petr Bulant C C----------------------------------------------------------------------- C C Local storage locations: INTEGER I CHARACTER*20 FORMAT CHARACTER*11 FORMU,SPARSU C FORMAT..String containing the output format. C INTEGER NUMLIN SAVE NUMLIN DATA NUMLIN/-1/ C C....................................................................... C C Setting output format: IF(NUMLIN.EQ.-1) THEN CALL RSEP3I('NUMLINM',NUMLIN,5) ENDIF FORMAT='(00(E13.7,1X))' FORMAT(3:3)=CHAR(ICHAR('0')+MOD(NUMLIN,10)) FORMAT(2:2)=CHAR(ICHAR('0')+ NUMLIN/10 ) C C Writing the array: FORMU=FORM CALL UPPER(FORMU) SPARSU=SPARSE CALL UPPER(SPARSU) IF(SPARSU.EQ.'CSC') THEN C Sparse matrix: IF(FORMU.EQ.'FORMATTED') THEN C FORMAT='(00(I0,1X,E13.7,1X))' FORMAT(5:20)='I0,1X,E13.7,1X))' IF (M1.GT.999999999) THEN C MAT-04 CALL ERROR * ('MAT-04: Insufficient space in format specification') ELSE IF (M1.GT.99999999) THEN FORMAT(6:6)='9' ELSE IF (M1.GT.9999999) THEN FORMAT(6:6)='8' ELSE IF (M1.GT.999999) THEN FORMAT(6:6)='7' ELSE IF (M1.GT.99999) THEN FORMAT(6:6)='6' ELSE IF (M1.GT.9999) THEN FORMAT(6:6)='5' ELSE IF (M1.GT.999) THEN FORMAT(6:6)='4' ELSE IF (M1.GT.99) THEN FORMAT(6:6)='3' ELSE IF (M1.GT.9) THEN FORMAT(6:6)='2' ELSE FORMAT(6:6)='1' END IF WRITE(LU,FORMAT) * (IRAM(I),RAM(I+1),I=IMAT,IMAT+2*NELEM-1,2) ELSE WRITE(LU) * (IRAM(I),RAM(I+1),I=IMAT,IMAT+2*NELEM-1,2) END IF ELSE C Dense (not sparse) matrix: IF(FORMU.EQ.'FORMATTED') THEN WRITE(LU,FORMAT) (RAM(I),I=IMAT,IMAT+NELEM-1) ELSE WRITE(LU) (RAM(I),I=IMAT,IMAT+NELEM-1) END IF END IF C RETURN END C======================================================================= C C C SUBROUTINE TMATR(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA C C Subroutine designed to transpose a matrix. C C Input: C M1 ... Number of rows of the matrix. C M2 ... Number of columns of the matrix. C ISYM... Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C NSPAR...Sparseness of the matrix. C NSPAR.LT.0: Matrix is stored element by element. C NSPAR.GE.0: Matrix is stored as a sparse matrix, C NSPAR is the number of zero matrix elements. C NELEM...Number of elements of the matrix stored in array RAM. C MTMP .. Dimension of auxiliary arrays IATMP and ATMP. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. Entire arrays (I)RAM C from MIA to MAA may be used for temporary storage. C For NSPAR.LT.0 and general matrix (symmetry=' '), C MAA-MIA+1 must be at least 2*NELEM. For NSPAR.LT.0 and C other symmetries, MAA-MIA+1 may equal NELEM. C For NSPAR.GE.0, MAA-MIA+1 must be at least NA+NAout. C IA ... Address of the first storage location in array (I)RAM C used for the matrix. C NA ... Number of storage locations for the input matrix. C C Output: C M1 ... Number of rows of the transposed matrix. C M2 ... Number of columns of the transposed matrix. C IA ... If possible, IAout equals IAin. For sparse matrix stored C at the end of (I)RAM and NAout.GT.NAin, IAout is set to C MAA-NAout+1. C NA ... Number of storage locations for the output matrix. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER I1,I2,I3,I4,IAOLD,IANEW,IB,NB CHARACTER*72 TXTERR C C....................................................................... C IF (ISYM.EQ.1.OR.ISYM.EQ.2) THEN C Symmetric or diagonal matrix RETURN ENDIF IF (ISYM.EQ.3) THEN C Antisymmetric matrix IF (NSPAR.GE.0) THEN C Sparse matrix DO 1, I1=IA+M2+1+1,IA-1+NA,2 RAM(I1)=-RAM(I1) 1 CONTINUE ELSE C Normal (not sparse) matrix DO 10, I1=IA,IA-1+NA RAM(I1)=-RAM(I1) 10 CONTINUE ENDIF RETURN ENDIF C General matrix: IF (NSPAR.GE.0) THEN C Transposing sparse matrix: NB=NA-M2+M1 IF (NA+NB.GT.MAA-MIA+1) THEN C MAT-05 WRITE(TXTERR,'(A,I9,A)') * 'MAT-05: Array RAM too small,',NA+NB-(MAA-MIA+1), * ' units missing.' CALL ERROR(TXTERR) ENDIF IAOLD=IA IF (MAA-(IA+NA-1).LT.NB) THEN IANEW=MAA-(NA+NB)+1 CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW) ENDIF IB=IA+NA C Computing lengths of columns of transp(A): DO 20, I1=0,M1 IRAM(IB+I1)=0 20 CONTINUE DO 24, I1=1,M2 DO 22, I2=IRAM(IA-1+I1),IRAM(IA+I1)-2,2 I3=IB+IRAM(I2) IRAM(I3)=IRAM(I3)+1 22 CONTINUE 24 CONTINUE C Computing pointers of transp(A) from lengths: IRAM(IB)=IB+M1+1 DO 26, I1=1,M1 IRAM(IB+I1)=IRAM(IB+I1-1)+2*IRAM(IB+I1) 26 CONTINUE C Creating transp(A): DO 30, I1=1,M2 DO 28, I2=IRAM(IA-1+I1),IRAM(IA+I1)-2,2 I3=IRAM(I2) I4=IRAM(IB-1+I3) IRAM(I4)=I1 RAM(I4+1)=RAM(I2+1) IRAM(IB-1+I3)=I4+2 28 CONTINUE 30 CONTINUE DO 32, I1=M1,1,-1 IRAM(IB+I1)=IRAM(IB-1+I1) 32 CONTINUE IRAM(IB)=IB+M1+1 C Shifting transposed matrix to the original position: IA=IB NA=NB I1=M1 M1=M2 M2=I1 IF (IAOLD-1+NA.LE.MAA) THEN CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IAOLD) ENDIF ELSE C Transposing normal (not sparse) matrix: IF (2*NELEM.GT.MAA-MIA+1) THEN C MAT-06 WRITE(TXTERR,'(A,I9,A)') * 'MAT-06: Array RAM too small,',2*NELEM-(MAA-MIA+1), * ' units missing.' CALL ERROR(TXTERR) ENDIF IAOLD=IA IF (MAA-(IA+NELEM-1).LT.NELEM) THEN IANEW=MAA-2*NELEM+1 CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW) ENDIF I3=IA-1 I4=IA-1+NELEM DO 36, I2=1,M2 DO 34, I1=1,M1 RAM(I4+(I1-1)*M2+I2)=RAM(I3+(I2-1)*M1+I1) 34 CONTINUE 36 CONTINUE IA=I4+1 I1=M1 M1=M2 M2=I1 CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IAOLD) ENDIF C RETURN END C C======================================================================= C C C SUBROUTINE SMATRE(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA C C Subroutine designed to extend sparse symmetric or antisymmetric C matrix to the sparse general matrix. C Sparse matrix to be extended must be stored in form "as on a disk", C i.e. matrix indices in IARRAY(1) to IARRAY(NELEM) and values of matrix C elements in ARRAY(NELEM+1) to ARRAY(NELEM+NELEM). C C Input: C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C ISYM... Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C NSPAR...Sparseness of the matrix. Must be NSPAR.GE.0 on input. C NELEM...Number of elements of the matrix stored in array RAM. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. Entire arrays (I)RAM C from MIA to MAA may be used for temporary storage. C At least NA+2*NNE storage locations must be available, C where NNE is the number of nonzero elements of the C extended matrix. C IA ... Address of the first storage location in array IRAM C used for the matrix. C NA ... Number of storage locations for the input matrix. C C Output: C ISYM ...ISYM=4, matrix is extended to general matrix. C NSPAR...Sparseness of the extended matrix (NSPAR.GE.0). C NELEM...Number of elements of the extended matrix. C IA ... Address of the first storage location in array IRAM C used for the extended matrix. C If IA-1+M2+1+2*NNE.LE.MAA, IA is not changed. C Otherwise IA is set to MAA-(M2+1+2*NNE)+1. C NA ... Number of storage locations for the extended matrix. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,NELMAT,MSHIFT,VELEM INTEGER NELMAT REAL VELEM C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER I1,I2,I3,I4,NNE,IANEW,I2END REAL SYMMUL,VEL CHARACTER*72 TXTERR C C....................................................................... C IF ((NSPAR.LT.0).OR.((ISYM.NE.2).AND.(ISYM.NE.3))) THEN C MAT-07 CALL ERROR('MAT-07: Wrong invocation of SMATRE.') ENDIF C Calculating the new number of elements in the extended matrix: NNE=NELEM DO 3, I2=1,M2 DO 2, I3=IRAM(IA-1+I2),IRAM(IA+I2)-2,2 I1=IRAM(I3) IF (I1.NE.I2) NNE=NNE+1 2 CONTINUE 3 CONTINUE IF (M2+1+2*NNE.GT.MAA-MIA+1) THEN C MAT-08 WRITE(TXTERR,'(A,I9,A)') 'MAT-08: Array RAM too small,', * M2+1+2*NNE-(MAA-MIA+1),' units missing.' CALL ERROR(TXTERR) ENDIF C Multiplication switch for symmetric or antisymmetric matrix: IF (ISYM.EQ.2) THEN SYMMUL=1. ELSE SYMMUL=-1. ENDIF C Checking the available space for the extended matrix, C changing IA and shifting the matrix: IF (IA-1+M2+1+2*NNE.GT.MAA) THEN IANEW=MAA-(M2+1+2*NNE)+1 CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW) ENDIF C Constructing the extended matrix: I4=IA+M2+1+2*NNE DO 14, I2=M2,1 C Address of the old end of the column I2: I2END=IRAM(IA-1+I2+1)-2 C Updating the address of the beginning of column I2+1: IRAM(IA-1+I2+1)=I4 C Recording the values under the diagonal: DO 12, I1=M1,I2+1,-1 VEL=SYMMUL*VELEM(M1,M2,ISYM,NSPAR,IA,I2,I1) IF (VEL.NE.0.) THEN I4=I4-2 IRAM(I4)=I1 RAM(I4+1)=VEL ENDIF 12 CONTINUE C Copying the values on and above the diagonal: DO 13, I3=I2END,IRAM(IA-1+I2),-2 I4=I4-2 IRAM(I4)=IRAM(I3) RAM(I4+1)=RAM(I3+1) 13 CONTINUE 14 CONTINUE C ISYM=4 NSPAR=NELMAT(M1,M2,ISYM)-NNE NELEM=NNE NA=M2+1+2*NNE RETURN END C C======================================================================= C C C SUBROUTINE GSMATR(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA C C Subroutine designed to change normal (not sparse) matrix to the C sparse matrix. The sparse matrix is written to the end C of arrays I(RAM). C C Input: C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C ISYM... Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 ... diagonal matrix C SYM='sym' ... ISYM=2 ... symmetric matrix C SYM='skew' ... ISYM=3 ... skew matrix C SYM=' ' ... ISYM=4 ... general matrix C NSPAR...Sparseness of the matrix. Must be NSPAR.LT.0 on input. C NELEM...Number of elements of the matrix stored in array RAM. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. Entire arrays (I)RAM C from MIA to MAA may be used for temporary storage. C MAA-MIA should be at least M2+1+NAout, where NAout C stays for the value of NA on output, but higher value C of MAA-MIA is recommended. MAA-MIA equal to C NAin+M2+1+NAout is always sufficient. C IA ... Address of the first storage location in array RAM C used for the matrix. C NA ... Number of storage locations for the input matrix. C C Output: C NSPAR...Sparseness of the matrix. NSPAR.GE.0 on output. C NELEM...Number of nonzero elements of the matrix in arrays (I)RAM. C IA ... New address of the first storage location in array RAM C used for the matrix. IA equals MAA-NA+1 on output. C NA ... New number of storage locations for the sparse matrix. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,NSPMAT INTEGER NSPMAT C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER I1,I2,I11,I12,J1,J2,J3,NN,NSPARN,IANEW CHARACTER*72 TXTERR C C....................................................................... C IF ((NSPAR.GE.0).OR.(NELEM.NE.NA)) THEN C MAT-09 CALL ERROR('MAT-09: Wrong invocation of GSMATR.') ENDIF C C Number NSPARN of zero and NN of nonzero elements: NSPARN=NSPMAT(NA,RAM(IA)) NN=NA-NSPARN C C Moving the matrix to the optimum position: IF (IA.NE.MIA+M2+1) THEN IANEW=MAX0(MIA+M2+1,(MAA-(2*NN+NA)+1)) CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW) ENDIF C IF ((IA+2*NN).GT.(MAA)) THEN C MAT-10 I1=IA+2*NN-MAA WRITE(TXTERR,'(A,I9,A)') * 'MAT-10: Array RAM too small,',I1,' units missing.' CALL ERROR(TXTERR) ENDIF C Moving the nonzero elements of the matrix to the end of RAM, C storing the corresponding row indices of the elements, C storing the column pointers: J1=MAA J2=IA-1+NA J3=IA-1-(M2+1) C J1 points where to write the next element of the sparse matrix C J2 I3 points to the next element of the dense matrix C J3 points before the array of pointers C Pointer for column M2+1: IRAM(J3+M2+1)=MAA+1 C Loop over indices of columns: DO 20, I2=M2,1,-1 IF (ISYM.EQ.1) THEN I11=I2 I12=I2 ELSEIF (ISYM.EQ.2) THEN I11=I2 I12=1 ELSEIF (ISYM.EQ.3) THEN I11=I2-1 I12=1 ELSE I11=M1 I12=1 ENDIF C Loop over indices of rows of the column I2: DO 18, I1=I11,I12,-1 IF (RAM(J2).NE.0.) THEN IF (J1-1.LT.J2) THEN C MAT-11 CALL ERROR('MAT-11: Array RAM too small') C An attemp to change normal matrix to sparse matrix C "in place" failed, more memory is required. ENDIF C Moving the value, recording the row index: RAM(J1)=RAM(J2) IRAM(J1-1)=I1 J1=J1-2 ENDIF J2=J2-1 18 CONTINUE C Writing the pointer for column I2: IRAM(J3+I2)=J1+1 20 CONTINUE IF (J2.NE.IA-1) THEN C MAT-12 CALL ERROR('MAT-12: Disorder in GSMATR') C This error should not appear. ENDIF C Updating IA: IA=J1+1-(M2+1) C Moving the array of pointers to the proper position: IF (IA.NE.J3+1) THEN DO 30, I1=M2+1,1,-1 IRAM(IA-1+I1)=IRAM(J3+I1) 30 CONTINUE ENDIF C Recording the numbers corresponding to the sparse matrix: NA=2*NN+M2+1 NSPAR=NSPARN NELEM=NN C RETURN END C C======================================================================= C C C SUBROUTINE SGMATR(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA C C Subroutine designed to change sparse matrix to the normal (not sparse) C matrix. C C Input: C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C ISYM... Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C NSPAR...Sparseness of the matrix. C NELEM...Number of elements of the matrix stored in array RAM. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. Entire arrays (I)RAM C from MIA to MAA may be used for temporary storage. C There must be always enough memory for columns 1 to K C of sparse matrix plus K to M2 of dense matrix. C (MAA-MIA+1).GE.(NAin+NAout) is always sufficient. C IA ... Address of the first storage location in array IRAM C used for the matrix. C NA ... Number of storage locations for the input matrix. C C Output: C NSPAR...Sparseness of the matrix. NSPAR=-1 on output. C NELEM...Number of elements of the matrix stored in array RAM. C IA ... New address of the first storage location in array RAM. C If IAin-1+NAout.LE.MAA, IAout equals IAin. Otherwise C IAout equals maximum of (MIA,MAA-NAout-NAin+1). C NA ... New number of storage locations for the matrix. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,NELMAT,MSHIFT INTEGER NELMAT C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER I1,I2,I3,J1,J2,NNE,IANEW,IAOLD CHARACTER*72 TXTERR C C....................................................................... C IF (NSPAR.LT.0) RETURN C C Rewriting the matrix from the sparse form C to the normal (not sparse) form: C Number of elements of the dense matrix: NNE=NELMAT(M1,M2,ISYM) C Checking the memory, shifting the matrix if necessary: IAOLD=IA IF (IA-1+NA+NNE.GT.MAA) THEN IF (IA.GT.MIA) THEN IANEW=MAX0(MIA,MAA-NNE-NA+1) CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW) ENDIF ENDIF C J2 points to the current position in the dense matrix: J2=MIN0(MAA,IA-1+NA+NNE) DO 20, I2=M2,1,-1 C J1 points before the beginning of column I2 in the dense matrix: IF (ISYM.EQ.1) THEN J1=J2-1 ELSEIF (ISYM.EQ.2) THEN J1=J2-I2 ELSEIF (ISYM.EQ.3) THEN J1=J2-I2+1 ELSE J1=J2-M1 ENDIF IF (J1.LT.IRAM(IA+I2)-1) THEN C MAT-13 WRITE(TXTERR,'(A,I9,A)') * 'MAT-13: Array RAM too small,',IRAM(IA+I2)-1-J1, * ' units missing.' CALL ERROR(TXTERR) ENDIF DO 8, I3=J1+1,J2 RAM(I3)=0. 8 CONTINUE C Rewriting column I2: DO 10, I3=IRAM(IA+I2)-1,IRAM(IA+I2-1)+1,-2 I1=IRAM(I3-1) IF (ISYM.EQ.1) THEN RAM(J1+1)=RAM(I3) ELSE RAM(J1+I1)=RAM(I3) ENDIF 10 CONTINUE J2=J1 20 CONTINUE IA=J2+1 NA=NNE NELEM=NA NSPAR=-1 C If possible, shifting the matrix to the original IA: IF (IA.NE.IAOLD) THEN IF (IAOLD-1+NA.LE.MAA) THEN CALL MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IAOLD) ENDIF ENDIF C RETURN END C C======================================================================= C C C SUBROUTINE GSMAT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,RSPAR) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA REAL RSPAR C C Subroutine designed to calculate the number NSPAR of zero elements C of a normal (not sparse) matrix, and to change the matrix into the C sparse matrix if NSPAR/NELEM.GE.RSPAR and the number of storage C locations required for the sparse matrix is lower than NA. C If the matrix is changed to sparse, it is written to the end C of arrays I(RAM). C C Input: C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C ISYM... Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C NSPAR...Sparseness of the matrix. Must be NSPAR.LT.0 on input. C NELEM...Number of elements of the matrix stored in array RAM. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. Entire arrays (I)RAM C from MIA to MAA may be used for temporary storage. C IA ... Address of the first storage location in array RAM C used for the matrix. C NA ... Number of storage locations for the input matrix. C RSPAR...Minimum rate of sparseness to change the matrix C into the sparse matrix. C C Output: C For NSPAR.LT.0 on output, only the value of RSPAR is C calculated, and there are no other changes on output: C RSPAR...Rate of sparseness of the matrix. (Number of zero elements C of the matrix divided by the number of all elements.) C Otherwise: C NSPAR...Number of zero elements of the matrix. NSPAR.GE.0. C NELEM...Number of nonzero elements of the matrix. C IA ... New address of the first storage location in array IRAM. C NA ... New number of storage locations for the matrix. C RSPAR...Rate of sparseness of the matrix. (Number of zero elements C of the matrix divided by the number of all elements.) C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,NSPMAT,GSMATR,MSHIFT INTEGER NSPMAT C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER NN REAL RSP0 C C....................................................................... C IF ((NSPAR.GE.0).OR.(NELEM.NE.NA)) THEN C MAT-14 CALL ERROR('MAT-14: Wrong invocation of GSMAT.') ENDIF C Number of zero elements: NN=NSPMAT(NA,RAM(IA)) RSP0=RSPAR RSPAR=FLOAT(NN)/FLOAT(NA) IF ((RSPAR.LT.RSP0).OR.(M2+1+2*(NA-NN).GT.NA).OR. * (M2+1+NA.GT.MAA-MIA)) THEN C Matrix will stay non-sparse. RETURN ENDIF C Changing the matrix into the sparse matrix: CALL GSMATR(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA) C RETURN END C C======================================================================= C C C REAL FUNCTION VELEM(M1,M2,ISYM,NSPARS,IA,IROW,ICOL) INTEGER M1,M2,ISYM,NSPARS,IA,IROW,ICOL C C Subroutine designed to calculate Value of ELEMent of a matrix. C C Input: C M1 ... Number of rows of the matrix. C M2 ... Number of columns of the matrix. C ISYM... Index of the symmetry of the matrix. C NSPARS. Sparseness of the matrix. C IA ... Address of the first storage location of the matrix. C IROW .. Number of the row of the matrix element. C ICOL ...Number of the column of the matrix element. C For the detailed description of storage of matrices in the memory C refer to above. C C Output: C VELEM...Value of the matrix element. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER IRO,ICO,II1,II2,II3,II21,IR1,IR2,IR3 REAL RMUL C....................................................................... C IF (NSPARS.GE.0) THEN C Sparse matrix, searching for VELEM by halving intervals: VELEM=0. C For diagonal of antisymmetric matrix: IF ((ISYM.EQ.3).AND.(IROW.EQ.ICOL)) RETURN RMUL=1. IRO=IROW ICO=ICOL IF (((ISYM.EQ.2).OR.(ISYM.EQ.3)).AND.(IROW.GT.ICOL)) THEN C (Anti)symmetric matrix: Aij=RMUL*Aji IRO=ICOL ICO=IROW IF (ISYM.EQ.3) RMUL=-1. ENDIF C Searching between beginning and end of column ICO. C II1 and II2 are the adresses of the two matrix elements between C which we search, IR1 and IR2 are their indices of rows. II1=IRAM(IA+ICO-1) II2=IRAM(IA+ICO)-2 IF (II2.GE.II1) THEN IR1=IRAM(II1) IR2=IRAM(II2) IF (IR1.EQ.IRO) THEN VELEM=RMUL*RAM(II1+1) RETURN ENDIF IF (IR2.EQ.IRO) THEN VELEM=RMUL*RAM(II2+1) RETURN ENDIF IF ((IR1.LT.IRO).AND.(IRO.LT.IR2)) THEN C IRO may be between IR1 and IR2, halving the interval: 10 CONTINUE II21=II2-II1 IF (II21.GT.2) THEN C II3 and IR3 is the half of the interval: II3=II1+(II21/4)*2 IR3=IRAM(II3) IF (IR3.EQ.IRO) THEN VELEM=RMUL*RAM(II3+1) RETURN ENDIF IF (IR3.LT.IRO) THEN II1=II3 IR1=IR3 GOTO 10 ELSEIF (IRO.LT.IR3) THEN II2=II3 IR2=IR3 GOTO 10 ENDIF ENDIF ENDIF ENDIF ELSE C Non-sparse matrix: IF (ISYM.EQ.2) THEN C 'sym' IF (IROW.LE.ICOL) THEN VELEM=RAM(IA-1+(ICOL-1)*ICOL/2+IROW) ELSE VELEM=RAM(IA-1+(IROW-1)*IROW/2+ICOL) ENDIF ELSEIF (ISYM.EQ.3) THEN C 'skew' IF (IROW.LT.ICOL) THEN VELEM=RAM(IA-1+(ICOL-1)*(ICOL-2)/2+IROW) ELSEIF (IROW.EQ.ICOL) THEN VELEM=0. ELSE VELEM=-RAM(IA-1+(IROW-1)*(IROW-2)/2+ICOL) ENDIF ELSEIF (ISYM.EQ.1) THEN C 'diag' IF (IROW.EQ.ICOL) THEN VELEM=RAM(IA-1+ICOL) ELSE VELEM=0. ENDIF ELSE C ' ' VELEM=RAM(IA-1+(ICOL-1)*M1+IROW) ENDIF ENDIF RETURN END C C======================================================================= C C C INTEGER FUNCTION NELMAT(M1,M2,ISYM) INTEGER M1,M2,ISYM C C Integer function to calculate number of elements of non-sparse matrix. C C Input: C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C ISYM... Index of the symmetry of the matrix. C C Output: C NELMAT. Number of elements of M1*M2 non-sparse matrix C of given symmetry. Note that for indices corresponding to C symmetries 'diag', 'sym' and 'skew' number M2 is used C to calculate NELMAT. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C IF (ISYM.EQ.4) THEN C General matrix NELMAT=M1*M2 ELSEIF (ISYM.EQ.2) THEN C Symmetric matrix NELMAT=M2*(M2+1)/2 ELSEIF (ISYM.EQ.3) THEN C Skew matrix NELMAT=M2*(M2-1)/2 ELSEIF (ISYM.EQ.1) THEN C Diagonal matrix NELMAT=M2 ELSE C MAT-15 CALL ERROR('MAT-15: Wrong index of matrix symmetry.') C Input argument ISYM should be equal to 1, 2, 3 or 4. ENDIF C RETURN END C C======================================================================= C C C INTEGER FUNCTION NSPMAT(NELEM,ARRAY) INTEGER NELEM REAL ARRAY(*) C C Integer function to calculate number of zero elements of non-sparse c matrix. C C Input: C NELEM...Number of elements of the matrix. C ARRAY...Elements of the matrix. C C Output: C NSPMAT..Number of zero elements of the matrix. C C Coded by Petr Bulant C INTEGER I C----------------------------------------------------------------------- C NSPMAT=0 DO 10, I=1,NELEM IF (ARRAY(I).EQ.0.) NSPMAT=NSPMAT+1 10 CONTINUE C RETURN END C C C======================================================================= C C C INTEGER FUNCTION ISYM(SYM) CHARACTER*(*) SYM C C Integer function to assign the integer corresponding to the symmetry. C C Input: C SYM ... Symmetry of a matrix. C C Output: C ISYM... Integer number corresponding to the symmetry SYM. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C C Coded by Petr Bulant C C----------------------------------------------------------------------- C IF (SYM.EQ.'diag') THEN ISYM=1 ELSEIF (SYM.EQ.'sym' ) THEN ISYM=2 ELSEIF (SYM.EQ.'skew') THEN ISYM=3 ELSEIF (SYM.EQ.' ' ) THEN ISYM=4 ELSE C MAT-16 CALL ERROR('MAT-16: Wrong matrix symmetry.') C Input argument SYM should be equal C to one of strings ' ', 'sym', 'skew', 'diag'. ENDIF C RETURN END C C======================================================================= C C C SUBROUTINE MSHIFT(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IANEW C C Subroutine designed to shift the matrix in arrays (I)RAM C to the new position IANEW. C C Input: C M1... Number of rows of the matrix. C M2... Number of columns of the matrix. C ISYM... Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C NSPAR...Sparseness of the matrix. C NELEM...Number of elements of the matrix stored in arrays (I)RAM. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. C Only the storage locations between IA and IA+NA-1, c and between IANEW and IANEW+NA-1 are altered. C IA ... Address of the first storage location in arrays (I)RAM C used for the matrix. C NA ... Number of storage locations for the matrix. C IANEW.. Address of the first storage location in arrays (I)RAM C where the matrix is to be shifted. C C Output: C IA ... IA is changed to the value of IANEW. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER II,ISHIFT C C....................................................................... C IF (IANEW.EQ.IA) RETURN C IF ((IANEW.LT.MIA).OR.(IANEW+NA-1.GT.MAA).OR. * (IA.LT.MIA).OR.(IA+NA-1.GT.MAA)) THEN C MAT-17 CALL ERROR('MAT-17: Wrong invocation of MSHIFT.') C Storage locations IA to IA+NA-1 and C IANEW to IANEW+NA-1 must fit into the available memory. ENDIF C IF (NSPAR.LT.0) THEN C Non-sparse matrix: IF (IANEW.LT.IA) THEN DO 10, II=0,NA-1 RAM(IANEW+II)=RAM(IA+II) 10 CONTINUE ELSE DO 11, II=NA-1,0,-1 RAM(IANEW+II)=RAM(IA+II) 11 CONTINUE ENDIF ELSE C Sparse matrix, form CSC: ISHIFT=IANEW-IA IF (IANEW.LT.IA) THEN DO 30, II=0,M2 IRAM(IANEW+II)=IRAM(IA+II)+ISHIFT 30 CONTINUE DO 31, II=0,NELEM-1 IRAM(IANEW+M2+1+II*2) =IRAM(IA+M2+1+II*2) RAM(IANEW+M2+1+II*2+1)= RAM(IA+M2+1+II*2+1) 31 CONTINUE ELSE DO 32, II=NELEM-1,0,-1 RAM(IANEW+M2+1+II*2+1)= RAM(IA+M2+1+II*2+1) IRAM(IANEW+M2+1+II*2) =IRAM(IA+M2+1+II*2) 32 CONTINUE DO 33, II=M2,0,-1 IRAM(IANEW+II)=IRAM(IA+II)+ISHIFT 33 CONTINUE ENDIF ENDIF C IA=IANEW RETURN END C C======================================================================= C C C SUBROUTINE OMAT(LU,FILE,IRW,FORMM) CHARACTER*(*) FILE,FORMM INTEGER LU,IRW C C Subroutine for backward compatibility. C C Coded by Petr Bulant C C----------------------------------------------------------------------- RETURN END C C======================================================================= C C C SUBROUTINE WMAT(LU,FILE,M1,M2,OUT) CHARACTER*(*) FILE INTEGER LU,M1,M2 REAL OUT(*) C C Subroutine for backward compatibility. WMATH and WMATD should be used C instead of using WMAT !!! 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 header file name. Must not be blank. 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 and Petr Bulant C C----------------------------------------------------------------------- C C Local storage locations: C EXTERNAL ISYM,NELMAT,WMATD,WMATH,ERROR INTEGER ISYM,NELMAT CHARACTER*13 FORMM INTEGER I1,I2,NELEM C C FORMM ..Form of the files with matrices. C C....................................................................... C CHARACTER*80 FILED CHARACTER*13 FORMAT CHARACTER*4 SYMM C IF (FILE.EQ.' ') THEN C MAT-18 CALL ERROR('MAT-18: Matrix header file not given') C In this version of WMAT, the matrix header file C must be specified and sequential writing of matrix data file C is not allowed. ENDIF FORMM=' ' FILED=' ' IF(M2.EQ.0) THEN C Symmetric matrix I2=M1 SYMM='sym' ELSEIF(M2.EQ.-1) THEN C Diagonal matrix I2=M1 SYMM='diag' ELSE C General matrix I2=M2 SYMM=' ' END IF NELEM=NELMAT(M1,I2,ISYM(SYMM)) CALL WMATH(LU,FILE,FILED,M1,I2,' ',NELEM,SYMM,FORMM) C FORMAT='(5(G14.7,1X))' C Writing the matrix: OPEN(LU,FILE=FILED,FORM=FORMM) IF(M2.EQ.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*IABS(M2),M1 WRITE(LU,FORMAT) (OUT(I1),I1=I2-M1+1,I2) 12 CONTINUE ELSE WRITE(LU) (OUT(I1),I1=1,M1*IABS(M2)) ENDIF END IF CLOSE(LU) 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 for backward compatibility. RMATH and RMATD should be used C instead of using RMAT !!! C Subroutine designed to read a matrix from the file. C In this version of RMAT sequential reading of matrix data file C is not allowed. C C Input: C LU... Logical unit number to be used for the input. C FILE... Destination header file name. Must not be blank. 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 ARRAY 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 and Petr Bulant C C----------------------------------------------------------------------- C EXTERNAL RMATD,RMATH,ERROR C Local storage location: CHARACTER*13 FORMM,SPARSE CHARACTER*80 FILED CHARACTER*4 SYMM INTEGER I,M1R,M2R,NELEM C IF (FILE.EQ.' ') THEN C MAT-19 CALL ERROR('MAT-19: Matrix header file not given') C In this version of RMAT, the matrix header file C must be specified and sequential reading of matrix data file C is not allowed. ENDIF CALL RMATH(LU,FILE,FILED,M1R,M2R,SPARSE,NELEM,SYMM,FORMM) IF ((M1.NE.M1R).OR.(SPARSE.NE.' ').OR.(SYMM.EQ.'skew').OR. * ((SYMM.EQ.'sym' ).AND.(M2.NE.0)).OR. * ((SYMM.EQ.' ' ).AND.(M2.NE.M2R)).OR. * ((SYMM.EQ.'diag').AND.(M2.NE.1))) THEN C MAT-20 CALL ERROR('MAT-20: Unexpected values in matrix header file.') C Some of the values of the matrix header file differs from C the values estimated using input parameters M1 and M2. C For example, this version of RMAT cannot deal with sparse C matrices. ENDIF C OPEN(LU,FILE=FILED,FORM=FORMM) 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 CLOSE(LU) C RETURN END C C======================================================================= Cmatfun.for 0100666 0000765 0000765 00000034261 11024140020 012421 0 ustar bulant bulant CC Program MATFUN to compute diagonal matrix M2 as a function M2=FUN(M1) C of diagonal matrix M1. C C Version: 6.20 C Date: 2008, 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 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 Filenames of the header files of the matrices: C MATIN1='string' .. Name of the header file of the input matrix M1. C Matrix M1 must be diagonal. C No default, MATIN1 must be specified and cannot be blank. C MATOUT='string' . Name of the header file of the output matrix M2. C No default, MATOUT must be specified and cannot be blank. C For general description of the files with matrices refer to file C forms.htm. C Function to be applied to the matrix M1: C MATFUN='string' . String specifying the function: C 'abs' ... absolute value C 'aint'... part of the number before the decimal point C 'anint'.. nearest integer (note that output file with C matrix M2 is always written using real numbers, even C for functions 'aint' and 'anint') C 'sqrt'... square root C 'exp' ... exponential function C 'alog'... natural logarithm C 'alog10'. logarithm of 10 C 'sin' ... sinus C 'cos' ... cosinus C 'tan' ... tangent C 'asin'... arcus sinus C 'acos'... arcus cosinus C 'atan'... arcus tangent C 'sinh'... sinus hyperbolicus C 'cosh'... cosinus hyperbolicus C 'tanh'... tangent hyperbolicus C 'inv' ... inverse function (M2=1./M1) C No default, MATFUN must be specified and cannot be blank. C Form of the output file with the matrix M2: C FORMM='string' ... Form of the output file with the matrix. C Possible values of FORMM are: C FORMM='FORMATTED' ... formatted file C FORMM='UNFORMATTED' ... unformatted file C Default: FORMM='FORMATTED' C SPARSE=integer ... Identifies whether the matrix should be sparse. C Possible values of SPARSE are: C SPARSE=1 ... sparse matrix C SPARSE=0 ... automatic selection of the sparseness: C matrix with half or more zero elements will be sparse C in the index format, otherwise non-sparse matrix C SPARSE=-1 ... normal (not sparse) matrix C Default: SPARSE=0 (automatic selection of the sparseness) C For detailed description of the forms of the files with matrices C refer to file forms.htm. C Optional parameter specifying the form of the output formatted C matrix data files: C NUMLINM=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C mat.for. C C For detailed description of storage of matrices in the memory C refer to file mat.for. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3I,RSEP3T,UARRAY,LOWER,UPPER, *RMATH,RMATD,WMATH,WMATD,GSMAT,GSMATR,SGMATR,NELMAT,ISYM INTEGER NELMAT,ISYM REAL UARRAY C ERROR ... File error.for. C RSEP1,RSEP3I,RSEP3T ... C File sep.for. C LOWER,UPPER ... File C length.for. C UARRAY ... File C forms.for. C RMATH,RMATD,WMATH,WMATD,GSMAT,GSMATR,SGMATR,NELMAT,ISYM ... C File mat.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C CHARACTER*80 FILSEP,FILE1,FILE3,FILED1,FILED3,TFUN,SYM1,FORM1, * FORM3,SPARS1 INTEGER M1,M2,NEL1,IA,NA,ISYM1,NSPAR1,ISPAR3,LU1,I1,I11,I12,I13, * IFUN REAL RSPAR1,UNDEF CHARACTER*72 TXTERR PARAMETER (LU1=1) C UNDEF=UARRAY() C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+MATFUN: 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 MATFUN-01 CALL ERROR('MATFUN-01: SEP file not given.') ENDIF C C Reading the names of matrices header files: CALL RSEP3T('MATIN1',FILE1,' ') IF (FILE1.EQ.' ') THEN C MATFUN-02 CALL ERROR('MATFUN-02: File MATIN1 not given.') ENDIF CALL RSEP3T('MATOUT',FILE3,' ') FILED3=' ' IF (FILE3.EQ.' ') THEN C MATFUN-03 CALL ERROR('MATFUN-03: File MATOUT not given.') ENDIF C Reading the header file of the input matrix: CALL RMATH(LU1,FILE1,FILED1,M1,M2,SPARS1,NEL1,SYM1,FORM1) ISYM1=ISYM(SYM1) IF (SPARS1.EQ.' ') THEN NSPAR1=-1 ELSEIF (SPARS1.EQ.'CSC') THEN NSPAR1=NELMAT(M1,M2,ISYM1)-NEL1 ELSE C MATFUN-08 CALL ERROR('MATFUN-08: Wrong format of input matrix.') C In this version only dense or sparse CSC matrix is allowed. ENDIF IF (SYM1.NE.'diag') THEN C MATFUN-04 CALL ERROR('MATFUN-04: Input matrix is not diagonal.') ENDIF C Reading the properties of the output file: CALL RSEP3T('FORMM',FORM3,'FORMATTED') CALL UPPER(FORM3) CALL RSEP3I('SPARSE',ISPAR3,0) C C Reading the function: CALL RSEP3T('MATFUN',TFUN,' ') IF (TFUN.EQ.' ') THEN C MATFUN-05 CALL ERROR('MATFUN-05: Function MATFUN not given.') ENDIF CALL LOWER(TFUN) C C Registration of the function: C (numbers of functions correspond to 'grdcal.for') IFUN=-1 IF (TFUN.EQ.'abs') THEN IFUN= 6 ELSEIF (TFUN.EQ.'aint') THEN IFUN= 7 ELSEIF (TFUN.EQ.'anint') THEN IFUN= 8 ELSEIF (TFUN.EQ.'sqrt') THEN IFUN=14 ELSEIF (TFUN.EQ.'exp') THEN IFUN=15 ELSEIF (TFUN.EQ.'alog') THEN IFUN=16 ELSEIF (TFUN.EQ.'alog10') THEN IFUN=17 ELSEIF (TFUN.EQ.'sin') THEN IFUN=18 ELSEIF (TFUN.EQ.'cos') THEN IFUN=19 ELSEIF (TFUN.EQ.'tan') THEN IFUN=20 ELSEIF (TFUN.EQ.'asin') THEN IFUN=21 ELSEIF (TFUN.EQ.'acos') THEN IFUN=22 ELSEIF (TFUN.EQ.'atan') THEN IFUN=23 ELSEIF (TFUN.EQ.'sinh') THEN IFUN=25 ELSEIF (TFUN.EQ.'cosh') THEN IFUN=26 ELSEIF (TFUN.EQ.'tanh') THEN IFUN=27 ELSEIF (TFUN.EQ.'inv') THEN IFUN=28 ELSE GOTO 201 END IF C C Reading input matrix A: IA=1 IF (NSPAR1.GE.0) THEN NA=M2+1+2*NEL1 ELSE NA=NEL1 ENDIF IF (NA+1.GT.MRAM) THEN C MATFUN-07 WRITE(TXTERR,'(A,I9,A)') * 'MATFUN-07: Array RAM too small,',NA+1-MRAM,' units missing.' CALL ERROR(TXTERR) ENDIF CALL RMATD(LU1,FILED1,M2,SPARS1,NEL1,FORM1,IA) C C Applying the function: IF (NSPAR1.GE.0) THEN I11=IRAM(IA)+1 I12=IRAM(IA+M2)-1 I13=2 ELSE I11=1 I12=NEL1 I13=1 ENDIF DO 200, I1=I11,I12,I13 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,128) IFUN GO TO 201 101 CONTINUE c RAM(I1)=RAM(I1)+RNAME(I2) GO TO 201 102 CONTINUE c RAM(I1)=RAM(I1)-RNAME(I2) GO TO 201 103 CONTINUE c RAM(I1)=RAM(I1)*RNAME(I2) GO TO 201 104 CONTINUE c IF(RNAME(I2).EQ.0.) THEN c IF(RAM(I1).EQ.0.) THEN c RAM(I1)=0. c ELSE c RAM(I1)=UNDEF c END IF c ELSE c RAM(I1)=RAM(I1)/RNAME(I2) c END IF GO TO 201 105 CONTINUE c IF(RAM(I1).LT.0.) THEN c RAM(I1)=UNDEF c ELSE c RAM(I1)=RAM(I1)**RNAME(I2) c END IF GO TO 201 106 CONTINUE RAM(I1)=ABS(RAM(I1)) GO TO 200 107 CONTINUE RAM(I1)=AINT(RAM(I1)) GO TO 200 108 CONTINUE RAM(I1)=ANINT(RAM(I1)) GO TO 200 109 CONTINUE c IF(RNAME(I2).EQ.0.) THEN c RAM(I1)=UNDEF c ELSE c RAM(I1)=AMOD(RAM(I1),RNAME(I2)) c END IF GO TO 201 110 CONTINUE c RAM(I1)=SIGN(RAM(I1),RNAME(I2)) GO TO 201 111 CONTINUE c RAM(I1)=DIM(RAM(I1),RNAME(I2)) GO TO 201 112 CONTINUE c RAM(I1)=AMAX1(RAM(I1),RNAME(I2)) GO TO 201 113 CONTINUE c RAM(I1)=AMIN1(RAM(I1),RNAME(I2)) GO TO 201 114 CONTINUE IF(RAM(I1).LT.0.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=SQRT(RAM(I1)) END IF GO TO 200 115 CONTINUE RAM(I1)=EXP(RAM(I1)) GO TO 200 116 CONTINUE IF(RAM(I1).LE.0.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=ALOG(RAM(I1)) END IF GO TO 200 117 CONTINUE IF(RAM(I1).LE.0.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=ALOG10(RAM(I1)) END IF GO TO 200 118 CONTINUE RAM(I1)=SIN(RAM(I1)) GO TO 200 119 CONTINUE RAM(I1)=COS(RAM(I1)) GO TO 200 120 CONTINUE RAM(I1)=TAN(RAM(I1)) GO TO 200 121 CONTINUE IF(ABS(RAM(I1)).GT.1.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=ASIN(RAM(I1)) END IF GO TO 200 122 CONTINUE IF(ABS(RAM(I1)).GT.1.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=ACOS(RAM(I1)) END IF GO TO 200 123 CONTINUE IF(ABS(RAM(I1)).GT.1.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=ATAN(RAM(I1)) END IF GO TO 200 124 CONTINUE c IF(RAM(I1).EQ.0..AND.RNAME(I2).EQ.0.) THEN c RAM(I1)=UNDEF c ELSE c RAM(I1)=ATAN2(RAM(I1),RNAME(I2)) c END IF GO TO 201 125 CONTINUE RAM(I1)=SINH(RAM(I1)) GO TO 200 126 CONTINUE RAM(I1)=COSH(RAM(I1)) GO TO 200 127 CONTINUE RAM(I1)=TANH(RAM(I1)) GO TO 200 128 CONTINUE IF(RAM(I1).EQ.0.) THEN RAM(I1)=UNDEF ELSE RAM(I1)=1./RAM(I1) END IF GO TO 200 200 CONTINUE GOTO 202 201 CONTINUE C MATFUN-06 CALL ERROR ('MATFUN-06: Unsupported function') C The function given by input parameter MATFUN is not coded. 202 CONTINUE C IF ((ISPAR3.EQ.1).AND.(NSPAR1.LT.0)) THEN C Changing non-sparse matrix to sparse matrix: CALL GSMATR(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA) ELSEIF ((ISPAR3.EQ.-1).AND.(NSPAR1.GE.0)) THEN C Changing sparse matrix to non-sparse matrix: CALL SGMATR(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA) ELSEIF (ISPAR3.EQ.0) THEN C Automatic selection of the sparseness: IF (NSPAR1.LT.0) THEN C Matrix is non-sparse, it will be changed to sparse if its C sparseness is 0.5 or more: RSPAR1=0.5 CALL GSMAT(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA,RSPAR1) ELSE C Matrix is sparse. RSPAR1=FLOAT(NSPAR1)/FLOAT(NSPAR1+NEL1) IF (RSPAR1.LT.0.5) THEN C Matrix is sparse, sparseness is less than 0.5, thus changing C the sparse matrix to non-sparse matrix: CALL SGMATR(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA) ENDIF ENDIF ENDIF C C Writing output matrix: SPARS1=' ' IF (NSPAR1.GE.0) SPARS1='CSC' CALL WMATH(LU1,FILE3,FILED3,M1,M2,SPARS1,NEL1,SYM1,FORM3) CALL WMATD(LU1,FILED3,M1,M2,SPARS1,NEL1,FORM3,IA) C WRITE(*,'(A)') '+MATFUN: 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 INCLUDE 'mat.for' C mat.for C C======================================================================= Cmatinv.for 0100666 0000765 0000765 00000025542 11024140020 012427 0 ustar bulant bulant CC Program MATINV to compute symmetric matrix M2, which is inverse to C input symmetric matrix M1. C C Version: 6.20 C Date: 2008, 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 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 Filenames of the header files of the matrices: C MATIN1='string' .. Name of the header file of the input matrix M1. C Matrix M1 must be symmetric. C No default, MATIN1 must be specified and cannot be blank. C MATOUT='string' . Name of the header file of the output matrix M2. C No default, MATOUT 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 output file with the matrix M2: C FORMM='string' ... Form of the output file with the matrix. C Possible values of FORMM are: C FORMM='FORMATTED' ... formatted file C FORMM='UNFORMATTED' ... unformatted file C Default: FORMM='FORMATTED' C SPARSE=integer ... Identifies whether the matrix should be sparse. C Possible values of SPARSE are: C SPARSE=1 ... sparse matrix C SPARSE=0 ... automatic selection of the sparseness: C matrix with half or more zero elements will be sparse C in the index format, otherwise non-sparse matrix C SPARSE=-1 ... normal (not sparse) matrix C Default: SPARSE=0 (automatic selection of the sparseness) C For detailed description of the forms of the files with matrices C refer to file forms.htm. C Optional parameter specifying the form of the output formatted C matrix data files: C NUMLINM=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C mat.for. C C For detailed description of storage of matrices in the memory C refer to file mat.for. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL SMBLO,IND,ERROR,RSEP1,RSEP3I,RSEP3T,UPPER, * RMATH,RMATD,WMATH,WMATD,GSMAT,GSMATR,SGMATR,NELMAT,ISYM,SINV INTEGER IND,NELMAT,ISYM C SMBLO,IND ... This file. C ERROR ... File error.for. C RSEP1,RSEP3I,RSEP3T ... C File sep.for. C UPPER ... File C length.for. C RMATH,RMATD,WMATH,WMATD,GSMAT,GSMATR,SGMATR,NELMAT,ISYM ... C File mat.for. C SINV ... File sinv.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C CHARACTER*80 FILSEP,FILE1,FILE3,FILED1,FILED3,SYM1,FORM1, * FORM3,SPARS1 INTEGER M1,M2,NEL1,IA,NA,NSPAR1,ISPAR3,LU1,I1,I2,I3,I4, * N,NN,IANEW,NB,IBMI,IBMA,IER,ISYM1 REAL RSPAR1,EPS CHARACTER*72 TXTERR PARAMETER (LU1=1) C C----------------------------------------------------------------------- C EPS=0.000001 C C Reading a name of the file with the input data: WRITE(*,'(A)') '+MATINV: 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 MATINV-01 CALL ERROR('MATINV-01: SEP file not given.') ENDIF C C Reading the names of matrices header files: CALL RSEP3T('MATIN1',FILE1,' ') IF (FILE1.EQ.' ') THEN C MATINV-02 CALL ERROR('MATINV-02: File MATIN1 not given.') ENDIF CALL RSEP3T('MATOUT',FILE3,' ') FILED3=' ' IF (FILE3.EQ.' ') THEN C MATINV-03 CALL ERROR('MATINV-03: File MATOUT not given.') ENDIF C Reading the header file of the input matrix: CALL RMATH(LU1,FILE1,FILED1,M1,M2,SPARS1,NEL1,SYM1,FORM1) ISYM1=ISYM(SYM1) IF (SPARS1.EQ.' ') THEN NSPAR1=-1 ELSEIF (SPARS1.EQ.'CSC') THEN NSPAR1=NELMAT(M1,M2,ISYM1)-NEL1 ELSE C MATINV-06 CALL ERROR('MATINV-06: Wrong sparseness of the input matrix.') C In this version only dense or sparse CSC matrix is allowed. ENDIF IF (SYM1.NE.'sym') THEN C MATINV-07 CALL ERROR('MATINV-07: Input matrix is not symmetric.') ENDIF C Reading the properties of the output file: CALL RSEP3T('FORMM',FORM3,'FORMATTED') CALL UPPER(FORM3) CALL RSEP3I('SPARSE',ISPAR3,0) C N=M1 NN=M1*(M1+1)/2 IF (3*NN+N+1.GT.MRAM) THEN C MATINV-04 WRITE(TXTERR,'(A,I9,A)') * 'MATINV-04: Array RAM too small,',3*NN+N+1-MRAM,' units missing' CALL ERROR(TXTERR) END IF C C Reading input matrix: IF (NSPAR1.GE.0) THEN IA=1 NA=2*NEL1 ELSE IA=MRAM-NN+1 NA=NEL1 ENDIF CALL RMATD(LU1,FILED1,M2,SPARS1,NEL1,FORM1,IA) IF (NSPAR1.GE.0) THEN C Changing input matrix to non-sparse: CALL SGMATR(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA) IANEW=MRAM-NN+1 CALL MSHIFT(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA,IANEW) ENDIF C WRITE(*,'(A)') '+MATINV: 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 MATINV-05 WRITE(TXTERR,'(A,I5,A)') * 'MATINV-05: Error',IER,' in subroutine SINV' CALL ERROR(TXTERR) 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 IA=MRAM-2*NN-N IF (ISPAR3.EQ.1) THEN C Changing non-sparse matrix to sparse matrix: CALL GSMATR(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA) ELSEIF (ISPAR3.EQ.0) THEN C Automatic selection of the sparseness: C Matrix is non-sparse, it will be changed to sparse if its C sparseness is 0.5 or more: RSPAR1=0.5 CALL GSMAT(M1,M2,ISYM1,NSPAR1,NEL1,1,MRAM,IA,NA,RSPAR1) ENDIF C C Writing output matrix: SPARS1=' ' IF (NSPAR1.GE.0) SPARS1='CSC' CALL WMATH(LU1,FILE3,FILED3,M1,M2,SPARS1,NEL1,SYM1,FORM3) CALL WMATD(LU1,FILED3,M1,M2,SPARS1,NEL1,FORM3,IA) C WRITE(*,'(A)') '+MATINV: 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 'mat.for' C mat.for INCLUDE 'sinv.for' C sinv.for INCLUDE 'mfsd.for' C mfsd.for C C======================================================================= Cmatlin.for 0100666 0000765 0000765 00000036622 11024140020 012416 0 ustar bulant bulant CC Program MATLIN to compute matrix M3 as a linear combination C M3=COEF1*M1+COEF2*M2 of matrices M1 and M2. The matrices M1 and M2 C must have the same number of rows and the same number of columns, C and they must be of the same symmetry, resulting matrix M3 will have C the same symmetry. C C Version: 6.20 C Date: 2008, 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 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 Filenames of the header files of the matrices: C MATIN1='string' .. Name of the header file of the input matrix M1. C No default, MATIN1 must be specified and cannot be blank. C MATIN2='string' .. Name of the header file of the input matrix M2. C Default: MATIN2=' ' ... no input matrix M2, matrix M1 will C be written on output. This option may be used to multiply C matrix M1 by a constant, or to change its form. C MATOUT='string' . Name of the header file of the output matrix M3. C No default, MATOUT 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 output file with the matrix M3: C FORMM='string' ... Form of the output file with the matrix. C Possible values of FORMM are: C FORMM='FORMATTED' ... formatted file C FORMM='UNFORMATTED' ... unformatted file C Default: FORMM='FORMATTED' C SPARSE=integer ... Identifies whether the matrix should be sparse. C Possible values of SPARSE are: C SPARSE=1 ... sparse matrix C SPARSE=0 ... automatic selection of the sparseness: C matrix with half or more zero elements will be sparse C in the index format, otherwise non-sparse matrix C SPARSE=-1 ... normal (not sparse) matrix C Default: SPARSE=0 (automatic selection of the sparseness) C For detailed description of the forms of the files with matrices C refer to file forms.htm. C Coefficients to multiply the input matrices: C COEF1=real ... coefficient to multiply matrix M1. Must not be 0. C Default: COEF1=1. C COEF2=real ... Same as COEF1, but for matrix M2. C Default: COEF2=1. C Optional parameter specifying the form of the output formatted C matrix data files: C NUMLINM=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C mat.for. C C For detailed description of storage of matrices in the memory C refer to file mat.for. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3I,RSEP3T,UPPER,RMATH,RMATD,WMATH,WMATD, *GSMAT,GSMATR,SGMATR,ISYM,NELMAT,SWITCH INTEGER ISYM,NELMAT C ERROR ... File error.for. C RSEP1,RSEP3I,RSEP3T ... C File sep.for. C UPPER ... C File length.for. C RMATH,RMATD,WMATH,WMATD,GSMAT,GSMATR,SGMATR,ISYM,NELMAT ... C File mat.for. C SWITCH ... This file. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3,FILED1,FILED2,FILED3 CHARACTER*80 SYM1,SYM2,SYM3,FORM1,FORM2,FORM3 CHARACTER*80 SPARS1,SPARS2,SPARSC INTEGER M1,M2,M1B,M2B,NEL1,NEL2,NELC,IA,NA, *IB,NB,IC,NC,NSPAR1,NSPAR2,ISPAR3,NSPARC,ISYM1,ISYM2,ISYMC, *LU1,I1,I2,I3,I4,IROW,ICOL,KK REAL RSPAR3,COEF1,COEF2,AAA CHARACTER*72 TXTERR PARAMETER (LU1=1) C C----------------------------------------------------------------------- C C Reading a name of the file with the input data: WRITE(*,'(A)') '+MATLIN: 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 MATLIN-01 CALL ERROR('MATLIN-01: SEP file not given.') ENDIF C C Reading the names of matrices header files: CALL RSEP3T('MATIN1',FILE1,' ') IF (FILE1.EQ.' ') THEN C MATLIN-02 CALL ERROR('MATLIN-02: File MATIN1 not given.') ENDIF CALL RSEP3T('MATIN2',FILE2,' ') CALL RSEP3T('MATOUT',FILE3,' ') FILED3=' ' IF (FILE3.EQ.' ') THEN C MATLIN-03 CALL ERROR('MATLIN-03: File MATOUT not given.') ENDIF C Reading the multiplication coefficients: CALL RSEP3R('COEF1',COEF1,1.) CALL RSEP3R('COEF2',COEF2,1.) IF (COEF1.EQ.0.) THEN C MATLIN-10 CALL ERROR('MATLIN-10: COEF1 equal zero.') ENDIF C Reading the header file of the input matrix M1: CALL RMATH(LU1,FILE1,FILED1,M1,M2,SPARS1,NEL1,SYM1,FORM1) ISYM1=ISYM(SYM1) IF (SPARS1.EQ.' ') THEN NSPAR1=-1 ELSEIF (SPARS1.EQ.'CSC') THEN NSPAR1=NELMAT(M1,M2,ISYM1)-NEL1 ELSE C MATLIN-08 CALL ERROR('MATLIN-08: Wrong format of input matrix.') C In this version only dense or sparse CSC matrix is allowed. ENDIF C Reading the properties of the output file: SYM3=SYM1 CALL RSEP3T('FORMM',FORM3,'FORMATTED') CALL UPPER(FORM3) CALL RSEP3I('SPARSE',ISPAR3,0) C IF ((FILE2.EQ.' ').OR.(COEF2.EQ.0.)) THEN C Matrix M2 is not given, matrix M1 is to be multiplied by COEF1 C and written as output matrix M3: IA=1 C Reading input matrix A: IF (NSPAR1.GE.0) THEN NA=M2+1+2*NEL1 ELSE NA=NEL1 ENDIF IF (IA-1+NA.GT.MRAM) THEN C MATLIN-04 WRITE(TXTERR,'(A,I9,A)') 'MATLIN-04: Array RAM too small,', * IA-1+NA-MRAM,' units missing.' CALL ERROR(TXTERR) ENDIF CALL RMATD(LU1,FILED1,M2,SPARS1,NEL1,FORM1,IA) IC=IA NC=NA NSPARC=NSPAR1 NELC=NEL1 ISYMC=ISYM1 IF (COEF1.NE.1.) THEN IF (NSPARC.GE.0) THEN DO 2, I1=IRAM(IC)+1,IRAM(IC+M2)-1,2 RAM(I1)=RAM(I1)*COEF1 2 CONTINUE ELSE DO 4, I1=IC,IC+NELC-1 RAM(I1)=RAM(I1)*COEF1 4 CONTINUE ENDIF ENDIF GOTO 100 ENDIF C C Matrix M2 is given: CALL RMATH(LU1,FILE2,FILED2,M1B,M2B,SPARS2,NEL2,SYM2,FORM2) ISYM2=ISYM(SYM2) IF (SPARS2.EQ.' ') THEN NSPAR2=-1 ELSEIF (SPARS2.EQ.'CSC') THEN NSPAR2=NELMAT(M1B,M2B,ISYM2)-NEL2 ELSE C MATLIN-09 CALL ERROR('MATLIN-09: Wrong format of input sparse matrix.') C In this version only dense or sparse CSC matrix is allowed. ENDIF IF ((M1.NE.M1B).OR.(M2.NE.M2B).OR.(ISYM1.NE.ISYM2)) THEN C MATLIN-05 CALL ERROR('MATLIN-05: Wrong input matrices.') C The matrices M1 and M2 must have the same number of rows C and the same number of columns, and they must be of the C same symmetry. ENDIF IF ((NSPAR1.GE.0).AND.(NSPAR2.LT.0)) THEN C If first matrix is sparse and the second not, switching them: CALL SWITCH( * FILE1,FILED1,SPARS1,NSPAR1,SYM1,ISYM1,FORM1,NEL1,COEF1, * FILE2,FILED2,SPARS2,NSPAR2,SYM2,ISYM2,FORM2,NEL2,COEF2) ENDIF C Reading input matrix A: IF (NSPAR1.GE.0) THEN NA=M2+1+2*NEL1 IA=M2+1+2*(NEL1+NEL2) ELSE NA=NEL1 IA=1 ENDIF IF (IA+NA-1.GT.MRAM) THEN C MATLIN-06 WRITE(TXTERR,'(A,I9,A)') * 'MATLIN-06: Array RAM too small,',IA+NA-1-MRAM,' units missing.' CALL ERROR(TXTERR) ENDIF CALL RMATD(LU1,FILED1,M2,SPARS1,NEL1,FORM1,IA) C Reading input matrix B: IF (NSPAR2.GE.0) THEN NB=M2+1+2*NEL2 ELSE NB=NEL2 ENDIF IB=IA+NA IF (IB+NB-1.GT.MRAM) THEN C MATLIN-07 WRITE(TXTERR,'(A,I9,A)') * 'MATLIN-07: Array RAM too small,',IB+NB-1-MRAM,' units missing.' CALL ERROR(TXTERR) ENDIF CALL RMATD(LU1,FILED2,M2,SPARS2,NEL2,FORM2,IB) C C Summation: WRITE(*,'(A)') '+MATLIN: Calculating the linear combination ... ' C IF (NSPAR1.GE.0) THEN C Both matrices are sparse: IC=1 I3=IC+M2+1-2 IRAM(IC)=I3+2 C Loop over columns: DO 28, KK=1,M2 I1=IRAM(IA-1+KK) I2=IRAM(IB-1+KK) IF ((I1.LT.IRAM(IA+KK)).AND.(I2.LT.IRAM(IB+KK))) THEN 20 CONTINUE IF (IRAM(I1).LT.IRAM(I2)) THEN I3=I3+2 IRAM(I3)=IRAM(I1) RAM(I3+1)=RAM(I1+1)*COEF1 I1=I1+2 IF (I1.LT.IRAM(IA+KK)) GOTO 20 ELSEIF (IRAM(I1).EQ.IRAM(I2)) THEN AAA=RAM(I1+1)*COEF1+RAM(I2+1)*COEF2 IF (AAA.NE.0.) * THEN I3=I3+2 IRAM(I3)=IRAM(I1) RAM(I3+1)=AAA ENDIF I1=I1+2 I2=I2+2 IF (I1.LT.IRAM(IA+KK)) GOTO 20 IF (I2.LT.IRAM(IB+KK)) GOTO 20 ELSEIF (IRAM(I1).GT.IRAM(I2)) THEN I3=I3+2 IRAM(I3)=IRAM(I2) RAM(I3+1)=RAM(I2+1)*COEF2 I2=I2+2 IF (I2.LT.IRAM(IB+KK)) GOTO 20 ENDIF ENDIF DO 22, I4=I1,IRAM(IA+KK)-2 I3=I3+2 IRAM(I3)=IRAM(I4) RAM(I3+1)=RAM(I4+1)*COEF1 22 CONTINUE DO 24, I4=I2,IRAM(IB+KK)-2 I3=I3+2 IRAM(I3)=IRAM(I4) RAM(I3+1)=RAM(I4+1)*COEF2 24 CONTINUE IRAM(IC+KK)=I3+2 28 CONTINUE NELC=(IRAM(IC+M2)-IRAM(IC))/2 NC=M2+1+2*NELC ISYMC=ISYM1 NSPARC=NELMAT(M1,M2,ISYMC)-NELC ELSE C First matrix is non-sparse: IF (COEF1.NE.1.) THEN DO 40, I1=IA,IA+NEL1-1 RAM(I1)=RAM(I1)*COEF1 40 CONTINUE ENDIF IF (NSPAR2.GE.0) THEN DO 44, ICOL=1,M2 DO 42, I1=IRAM(IB-1+ICOL),IRAM(IB+ICOL)-2,2 IROW=IRAM(I1) IF (ISYM2.EQ.1) THEN I2=IA-1+IROW ELSEIF (ISYM2.EQ.2) THEN I2=IA-1+(ICOL-1)*ICOL/2+IROW ELSEIF (ISYM2.EQ.3) THEN I2=IA-1+(ICOL-1)*(ICOL-2)/2+IROW ELSE I2=IA-1+(ICOL-1)*M1+IROW ENDIF RAM(I2)=RAM(I2)+RAM(I1+1)*COEF2 42 CONTINUE 44 CONTINUE ELSE DO 50, I1=1,NEL1 RAM(IA-1+I1)=RAM(IA-1+I1)+RAM(IB-1+I1)*COEF2 50 CONTINUE ENDIF IC=1 NELC=NEL1 NC=NA ISYMC=ISYM1 NSPARC=NSPAR1 ENDIF C 100 CONTINUE C IF ((ISPAR3.EQ.1).AND.(NSPARC.LT.0)) THEN C Changing non-sparse matrix to sparse matrix: CALL GSMATR(M1,M2,ISYMC,NSPARC,NELC,1,MRAM,IC,NC) ELSEIF ((ISPAR3.EQ.-1).AND.(NSPARC.GE.0)) THEN C Changing sparse matrix to non-sparse matrix: CALL SGMATR(M1,M2,ISYMC,NSPARC,NELC,1,MRAM,IC,NC) ELSEIF (ISPAR3.EQ.0) THEN C Automatic selection of the sparseness: IF (NSPARC.LT.0) THEN C Matrix is non-sparse, it will be changed to sparse if its C sparseness is 0.5 or more: RSPAR3=0.5 CALL GSMAT(M1,M2,ISYMC,NSPARC,NELC,1,MRAM,IC,NC,RSPAR3) ELSE C Matrix is sparse. RSPAR3=FLOAT(NSPARC)/FLOAT(NSPARC+NELC) IF (RSPAR3.LT.0.5) THEN C Matrix is sparse, sparseness is less than 0.5, thus changing C the sparse matrix to non-sparse matrix: CALL SGMATR(M1,M2,ISYMC,NSPARC,NELC,1,MRAM,IC,NC) ENDIF ENDIF ENDIF C C Writing output matrix C: SPARSC=' ' IF (NSPARC.GE.0) SPARSC='CSC' CALL WMATH(LU1,FILE3,FILED3,M1,M2,SPARSC,NELC,SYM3,FORM3) CALL WMATD(LU1,FILED3,M1,M2,SPARSC,NELC,FORM3,IC) C WRITE(*,'(A)') '+MATLIN: Done. ' C STOP END C C======================================================================= C SUBROUTINE SWITCH( * FILE1,FILED1,SPARS1,NSPAR1,SYM1,ISYM1,FORM1,NEL1,COEF1, * FILE2,FILED2,SPARS2,NSPAR2,SYM2,ISYM2,FORM2,NEL2,COEF2) CHARACTER*(*) FILE1,FILED1,SPARS1,FILE2,FILED2,SPARS2,SYM1,SYM2, * FORM1,FORM2 CHARACTER*80 FILE3,FILED3,SPARS3,SYM3,FORM3 INTEGER NSPAR1,ISYM1,NEL1,NSPAR2,ISYM2,NEL2,NSPAR3,ISYM3,NEL3 REAL COEF1,COEF2,COEF3 C----------------------------------------------------------------------- FILE3 = FILE1 FILED3 = FILED1 SPARS3 = SPARS1 NSPAR3 = NSPAR1 SYM3 = SYM1 ISYM3 = ISYM1 FORM3 = FORM1 NEL3 = NEL1 COEF3 = COEF1 FILE1 = FILE2 FILED1 = FILED2 SPARS1 = SPARS2 NSPAR1 = NSPAR2 SYM1 = SYM2 ISYM1 = ISYM2 FORM1 = FORM2 NEL1 = NEL2 COEF1 = COEF2 FILE2 = FILE3 FILED2 = FILED3 SPARS2 = SPARS3 NSPAR2 = NSPAR3 SYM2 = SYM3 ISYM2 = ISYM3 FORM2 = FORM3 NEL2 = NEL3 COEF2 = COEF3 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 'mat.for' C mat.for C C======================================================================= Cmatmul.for 0100666 0000765 0000765 00000141071 11024140020 012424 0 ustar bulant bulant CC Program MATMUL to compute product M3=M1*M2 of two matrices M1 and M2. C Matrices M1 and M2 may be transposed before the multiplication. C C Version: 6.20 C Date: 2008, 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 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 Filenames of the header files of the matrices: C MATIN1='string' .. Name of the header file of the input matrix M1. C No default, MATIN1 must be specified and cannot be blank. C MATIN2='string' .. Name of the header file of the input matrix M2. C Default: MATIN2=' ' ... no input matrix M2, matrix M1 will C be written on output. This option may be used to transpose C matrix M1, or to change the form of the matrix M1. C MATOUT='string' . Name of the header file of the output matrix M3. C No default, MATOUT 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 output file with the matrix M3: C SYMMETRY='string' ... Symmetry of the matrix. For SYMMETRY='diag', C only the diagonal components of the matrix are calculated C and written to the output file, other components are not C calculated. Simmilarly for other symmetries. C Possible values of SYMMETRY are: C SYMMETRY='diag' ... diagonal matrix C SYMMETRY='sym' ... symmetric matrix C SYMMETRY='skew' ... antisymmetric matrix C SYMMETRY=' ' ... general matrix C Default: C For matrix M2 not specified (MATIN2=' '): C SYMMETRY equal to symmetry of matrix M1 C For both input matrices M1 and M2 diagonal: C SYMMETRY='diag' (output matrix M3 will be diagonal) C In other cases: C SYMMETRY=' ' (output matrix M3 will be general) C FORMM='string' ... Form of the output file with the matrix. C Possible values of FORMM are: C FORMM='FORMATTED' ... formatted file C FORMM='UNFORMATTED' ... unformatted file C Default: FORMM='FORMATTED' C SPARSE=integer ... Identifies whether the matrix should be sparse. C Possible values of SPARSE are: C SPARSE=1 ... sparse matrix in the CSC format C SPARSE=0 ... automatic selection of the sparseness: C matrix with half or more zero elements will be sparse C in the CSC format, otherwise non-sparse matrix C SPARSE=-1 ... normal (not sparse) matrix C Default: SPARSE=0 (automatic selection of the sparseness) C For general description of the forms of the files with matrices C refer to file forms.htm. C Switches identifying transposition of the input matrices: C MATT1=integer ... Identifies whether the matrix M1 is to be C transposed before the multiplication: C MATT1=0 ... no transposition C MATT1=1 ... matrix M1 is to be transposed C Default: MATT1=0 (no transposition of M1) C MATT2=integer ... Same as MATT1, but for matrix M2. C Default: MATT2=0 (no transposition of M2) C Optional parameter specifying the form of the output formatted C matrix data files: C NUMLINM=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C mat.for. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3I,RSEP3T,RMATH,RMATD,WMATH,WMATD, *TMATR,SMATRE,GSMAT,GSMATR,SGMATR,ISYM,NELMAT,MSHIFT,VELEM, *MMILOC,MMIRVE,OMULS,OMULNS,LOWER,UPPER INTEGER ISYM,NELMAT REAL VELEM C ERROR ... File error.for. C RSEP1,RSEP3I,RSEP3T,SSEP ... C File sep.for. C RMATH,RMATD,WMATH,WMATD,TMATR,SMATRE,GSMAT,GSMATR,SGMATR, C ISYM,NELMAT,MSHIFT,VELEM ... C File mat.for. C MMILOC,MMIRVE,OMULS,OMULNS,GSPART ... This file. C LOWER,UPPER ... File C length.for. C Subroutines and external functions referred by above subroutines: C LENGTH ... File C length.for. C WSEP3I,WSEP3T ... File C sep.for. C RARRAI,RARRAY,WARRAI,WARRAY ... C File forms.for. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C CHARACTER*80 FILSEP,FILE1,FILE2,FILE3,FILED1,FILED2,FILED3 CHARACTER*80 SYM1,SYM2,SYM3,SYM3I,FORM1,FORM2,FORM3 CHARACTER*80 SPARS1,SPARS2,SPARSC INTEGER MATT1,MATT2,M1,M2,M2B,M3,NEL1,NEL2,NELC,IA,IA1,IAN,NA, *IB,IB1,IBN,NB,IC,NC,MC,ICNEW,NCTMP,NCCOL,NTMP1,NTMP2, *NSPAR1,NSPAR2,ISPAR3,NSPARC,ISYM1,ISYM2,ISYM3,ISYMC,LU1, *I1,II,JJ,KK,II1,II2,II3,IIA,JJ1,JJ2,JJ3,JJA,IIKK,ICTMP1,JJKK,IIJJ REAL AA,BB,CIK,RSPAR1,RSPAR2,RSPAR3,BBB LOGICAL LSPARC CHARACTER*72 TXTERR PARAMETER (LU1=1) C C----------------------------------------------------------------------- C MINRAM=1 MAXRAM=MRAM C C Reading a name of the file with the input data: WRITE(*,'(A)') '+MATMUL: 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 MATMUL-01 CALL ERROR('MATMUL-01: SEP file not given.') ENDIF C C Reading the names of matrices header files: CALL RSEP3T('MATIN1',FILE1,' ') IF (FILE1.EQ.' ') THEN C MATMUL-02 CALL ERROR('MATMUL-02: File MATIN1 not given.') ENDIF CALL RSEP3T('MATIN2',FILE2,' ') CALL RSEP3T('MATOUT',FILE3,' ') FILED3=' ' IF (FILE3.EQ.' ') THEN C MATMUL-03 CALL ERROR('MATMUL-03: File MATOUT not given.') ENDIF C Reading the header files of the input matrices: CALL RMATH(LU1,FILE1,FILED1,M1,M2,SPARS1,NEL1,SYM1,FORM1) ISYM1=ISYM(SYM1) IF (SPARS1.EQ.' ') THEN NSPAR1=-1 ELSEIF (SPARS1.EQ.'CSC') THEN NSPAR1=NELMAT(M1,M2,ISYM1)-NEL1 ELSE C MATMUL-15 CALL ERROR('MATMUL-15: Wrong value of SPARSE of input matrix') C Only SPARSE=' ' or SPARSE='CSC' is allowed. ENDIF IF (FILE2.NE.' ') THEN CALL RMATH(LU1,FILE2,FILED2,M2B,M3,SPARS2,NEL2,SYM2,FORM2) ISYM2=ISYM(SYM2) IF (SPARS2.EQ.' ') THEN NSPAR2=-1 ELSEIF (SPARS2.EQ.'CSC') THEN NSPAR2=NELMAT(M2B,M3,ISYM2)-NEL2 ELSE C MATMUL-16 CALL ERROR('MATMUL-16: Wrong value of SPARSE of input matrix') C Only SPARSE=' ' or SPARSE='CSC' is allowed. ENDIF ENDIF C Reading the properties of the output file: IF (FILE2.EQ.' ') THEN SYM3I=SYM1 ELSEIF ((SYM1.EQ.'diag').AND.(SYM2.EQ.'diag')) THEN SYM3I='diag' ELSE SYM3I=' ' ENDIF CALL RSEP3T('SYMMETRY',SYM3,SYM3I) CALL LOWER(SYM3) ISYM3=ISYM(SYM3) CALL RSEP3T('FORMM',FORM3,'FORMATTED') CALL UPPER(FORM3) CALL RSEP3I('SPARSE',ISPAR3,0) C Reading the transposition switches: CALL RSEP3I('MATT1',MATT1,0) CALL RSEP3I('MATT2',MATT2,0) C C Reading input matrix A: IF (NSPAR1.GE.0) THEN NA=M2+1+2*NEL1 ELSE NA=NEL1 ENDIF IA=MAXRAM-NA+1 IF (NA+1.GT.MAXRAM) THEN C MATMUL-04 WRITE(TXTERR,'(A,I9,A)') * 'MATMUL-04: Array RAM too small,',NA+1-MAXRAM,' units missing.' CALL ERROR(TXTERR) C This is the memory needed to read the first matrix M1. ENDIF CALL RMATD(LU1,FILED1,M2,SPARS1,NEL1,FORM1,IA) C Checking whether the non-sparse matrix is to be changed to the C sparse matrix, changing the matrix: IF (NSPAR1.LT.0) THEN RSPAR1=0.5 CALL GSMAT(M1,M2,ISYM1,NSPAR1,NEL1,MINRAM,MAXRAM,IA,NA,RSPAR1) ELSE RSPAR1=FLOAT(NSPAR1)/FLOAT(NSPAR1+NEL1) ENDIF C Transposing input matrix A: IF (MATT1.EQ.1) THEN CALL TMATR(M1,M2,ISYM1,NSPAR1,NEL1,MINRAM,MAXRAM,IA,NA) CALL MSHIFT(M1,M2,ISYM1,NSPAR1,NEL1,MINRAM,MAXRAM,IA,NA, * MAXRAM-NA+1) ENDIF C Extending sparse matrix A: CCC IF ((NSPAR1.GE.0).AND.((SYM1.EQ.'sym').OR.(SYM1.EQ.'skew'))) THEN CCC CALL SMATRE CCC * (M1,M2,SYM1,NSPAR1,NEL1,IRAM(IA),RAM(IA),MAXRAM,NA,ISTORA) CCC ISYM1=ISYM(SYM1) CCC ENDIF C IF (FILE2.EQ.' ') THEN C Matrix A is to be written as output matrix C: M3=M2 IF (ISYM3.EQ.ISYM1) THEN C No change of matrix symmetry: IC=IA NC=NA NSPARC=NSPAR1 NELC=NEL1 ISYMC=ISYM1 C Copying matrix A to the position of C: ICNEW=MINRAM CALL MSHIFT(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM,IC,NC,ICNEW) ELSE C Changing matrix symmetry: IF ((ISYM3.LE.3).AND.(M1.NE.M3)) THEN C MATMUL-05 CALL ERROR('MATMUL-05: Wrong symmetry of output matrix.') C If the output matrix should have symmetry 'diag', 'sym' or C 'skew', it must have the same number of rows and columns. ENDIF IF (ISYM3.EQ.2) THEN C Symmetric matrix NC=M1*(M1+1)/2 ELSEIF (ISYM3.EQ.3) THEN C Antisymmetric matrix NC=M1*(M1-1)/2 ELSEIF (ISYM3.EQ.1) THEN C Diagonal matrix NC=M1 ELSE C General matrix NC=M1*M3 ENDIF IC=MINRAM MC=IA-1 NSPARC=-1 NELC=NC ISYMC=ISYM3 C NCTMP=0 ICTMP1=IC-1 DO 15, KK=1,M3 C Preparing sufficient number of the storage locations: C Number NCCOL of storage locations for column KK: IF (ISYMC.EQ.1) THEN NCCOL=1 ELSEIF (ISYMC.EQ.2) THEN NCCOL=KK ELSEIF (ISYMC.EQ.3) THEN NCCOL=KK-1 ELSE NCCOL=M1 ENDIF IF (IC-1+NCTMP+NCCOL.GT.MC) THEN C Erasing unneeded columns 1 to KK-1 of A: IF (NSPAR1.LT.0) THEN C IA stays unchanged, MC is redefined: IF (ISYM1.EQ.1) THEN MC=IA+KK-1-1 ELSEIF (ISYM1.EQ.2) THEN MC=IA+(KK-1)*KK/2-1 ELSEIF (ISYM1.EQ.3) THEN MC=IA+(KK-2)*(KK-1)/2-1 ELSE MC=IA+M1*(KK-1)-1 ENDIF ELSE C IA must be changed, addresses of the ends of the columns C must be moved: IAN=IRAM(IA+KK-1)-M2-1 DO 12, I1=M2,0,-1 IF (I1.GE.KK-1) THEN IRAM(IAN+I1)=IRAM(IA+I1) ELSE IRAM(IAN+I1)=IRAM(IA+KK-1) ENDIF 12 CONTINUE IA=IAN MC=IA-1 ENDIF IF (IC-1+NCTMP+NCCOL.GT.MC) THEN C Changing the written part of C to sparse matrix: CALL GSPART(M1,M3,ISYMC,NSPARC,NELC,MINRAM,IA-1, * IC,NCTMP,KK-1,ICTMP1) ENDIF IF (IC-1+NCTMP+NCCOL.GT.MC) THEN C MATMUL-06 WRITE(TXTERR,'(A,I9,A)') * 'MATMUL-06: Array RAM too small,',IC-1+NCTMP+NCCOL-MC, * ' units missing.' CALL ERROR(TXTERR) ENDIF ENDIF C Initiating the values in column KK of C: DO 11, I1=IC-1+NCTMP+1,IC-1+NCTMP+NCCOL RAM(I1)=0. 11 CONTINUE C Preparing loop over column KK of A: CALL MMILOC(M1,M2,ISYM1,NSPAR1,IA,KK,II1,II2,II3) C Loop over nonzero elements of column KK of A: DO 13, IIA=II1,II2,II3 C Computing index II of row and value AA of element of A: CALL MMIRVE(M1,M2,ISYM1,NSPAR1,IA,KK,IIA,II1,II3,II,AA) IF ((ISYMC.EQ.1).AND.(II.EQ.KK)) THEN IIKK=ICTMP1+II ELSEIF ((ISYMC.EQ.2).AND.(II.LE.KK)) THEN IIKK=ICTMP1+(KK-1)*KK/2+II ELSEIF ((ISYMC.EQ.3).AND.(II.LT.KK)) THEN IIKK=ICTMP1+(KK-2)*(KK-1)/2+II ELSEIF (ISYMC.EQ.4) THEN IIKK=ICTMP1+(KK-1)*M1+II ELSE GOTO 13 ENDIF C Storing the element: RAM(IIKK)=AA IF (((ISYM1.EQ.2).OR.(ISYM1.EQ.3)).AND.(II.NE.KK).AND. * (ISYMC.EQ.4)) THEN C A is (anti)symmetric, storing also Aki=(-)Aik: IIKK=ICTMP1+(II-1)*M1+KK IF (ISYM1.EQ.3) AA=-AA RAM(IIKK)=AA ENDIF 13 CONTINUE NCTMP=NCTMP+NCCOL 15 CONTINUE IF (NSPARC.GE.0) THEN C Changing the remaining part of C to sparse matrix: CALL GSPART(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM, * IC,NCTMP,M3,ICTMP1) ENDIF ENDIF GOTO 100 ENDIF C C Reading input matrix B: IF (((MATT2.EQ.0).AND.(M2B.NE.M2)).OR. * ((MATT2.EQ.1).AND.(M3 .NE.M2))) THEN C MATMUL-07 CALL ERROR('MATMUL-07: Mismatch in dimensions of the matrices.') ENDIF IF ((ISYM3.LE.3).AND.(((MATT2.EQ.0).AND.(M1.NE.M3)).OR. * ((MATT2.EQ.1).AND.(M2.NE.M3)))) THEN C MATMUL-08 CALL ERROR('MATMUL-08: Wrong symmetry of output matrix.') C If the output matrix should have symmetry 'diag', 'sym' or C 'skew', it must have the same number of rows and columns. ENDIF IF (NSPAR2.GE.0) THEN NB=M3+1+2*NEL2 ELSE NB=NEL2 ENDIF IB=IA-NB IF (NB+1.GT.MAXRAM-MINRAM-NA) THEN C MATMUL-09 WRITE(TXTERR,'(A,I9,A)') * 'MATMUL-09: Array RAM too small,',NB+1-(MAXRAM-MINRAM-NA), * ' units missing.' CALL ERROR(TXTERR) ENDIF CALL RMATD(LU1,FILED2,M3,SPARS2,NEL2,FORM2,IB) C Checking whether the non-sparse matrix is to be changed to the C sparse matrix, changing the matrix: IF (NSPAR2.LT.0) THEN RSPAR2=0.5 CALL GSMAT(M2B,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB,RSPAR2) ELSE RSPAR2=FLOAT(NSPAR2)/FLOAT(NSPAR2+NEL2) ENDIF C Transposing input matrix B: IF (MATT2.EQ.1) THEN CALL TMATR(M2B,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB) CALL MSHIFT(M2B,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB,IA-NB) ENDIF C Extending sparse matrix B: IF ((NSPAR1.GE.0).AND.((SYM1.EQ.'sym').OR.(SYM1.EQ.'skew')).AND. * ((SYM2.EQ.'sym').OR.(SYM2.EQ.'skew'))) THEN CALL SMATRE(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB) SYM2=' ' ENDIF C C Optimizations for the speed of calculation: IF (((1.-RSPAR1)*(1.-RSPAR2).LE.0.5).AND. * (.NOT.((NSPAR1.LT.0).AND.(ISYM1.EQ.2.OR.ISYM1.EQ.3))).AND. * (.NOT.((NSPAR2.LT.0).AND.(ISYM2.EQ.2.OR.ISYM2.EQ.3)))) THEN C Matrices are to be multiplied as sparse matrices: C Checking if there is enough of memory for multiplication: C Calculating IC for the case that B will be sparse: CALL OMULS(M1,ISYM3,M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1, * IB,NB,IC) IAN=MINRAM+IA-IC C Shifting IC if A is to be changed to sparse: IF (NSPAR1.LT.0) THEN IC=IC + NA - (2*NINT((1.-RSPAR1)*FLOAT(NA))+M2+1) ENDIF IF (IC.GE.MINRAM) THEN C Matrices may be (and will be) changed to sparse matrices C and shifted to optimum position for multiplication: IF (NSPAR2.LT.0) THEN C Changing B to sparse: CALL GSMATR(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB) ENDIF C Shifting B to the beginning of RAM: CALL MSHIFT(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB,MINRAM) IF (NSPAR1.LT.0) THEN C Changing A to sparse: CALL GSMATR(M1,M2,ISYM1,NSPAR1,NEL1,IB+NB,MAXRAM,IA,NA) ENDIF C Shifting A to the optimum position for multiplication: CALL MSHIFT(M1,M2,ISYM1,NSPAR1,NEL1,IB+NB,MAXRAM,IA,NA,IAN) C Shifting B to the optimum position for multiplication: CALL MSHIFT(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB,IA-NB) ENDIF ELSE C Matrices are to be multiplied as non-sparse matrices: C Checking the memory needed for conversion of matrices C into non-sparse form: NTMP1=0 NTMP2=0 IF (NSPAR1.GE.0) NTMP1=M1 IF (NSPAR2.GE.0) NTMP2=M2 IF ((NELMAT(M1,M2,ISYM1)+NELMAT(M2,M3,ISYM2)+MAX0(NTMP1,NTMP2)) * .LE.MAXRAM) THEN C There is enough RAM for both matrices non-sparse plus the C auxiliary array to change them to non-sparse. C Calculating IC for the case that B will be non-sparse: CALL OMULNS(M1,ISYM3,M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1, * IB,NB,IC) IAN=MINRAM+IA-IC C Shifting IC if A is to be changed to non-sparse: IF (NSPAR1.GE.0) THEN IC=IC + NA - NELMAT(M1,M2,ISYM1) ENDIF C Shifting B to the beginning of RAM: CALL MSHIFT(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,MAXRAM, * IB,NB,MINRAM) IF (NSPAR2.GE.0) THEN C Changing B to non-sparse: CALL SGMATR(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB) ENDIF IF (NSPAR1.GE.0) THEN C Shifting A behind B: CALL MSHIFT(M1,M2,ISYM1,NSPAR1,NEL1,IB+NB,MAXRAM, * IA,NA,IB+NB) C Changing A to non-sparse: CALL SGMATR(M1,M2,ISYM1,NSPAR1,NEL1,IB+NB,MAXRAM,IA,NA) ENDIF C Shifting A to the optimum position for multiplication: IF (IC.LT.MINRAM) IAN=MAXRAM-NA+1 CALL MSHIFT(M1,M2,ISYM1,NSPAR1,NEL1,IB+NB,MAXRAM,IA,NA,IAN) C Shifting B to the optimum position for multiplication: CALL MSHIFT(M2,M3,ISYM2,NSPAR2,NEL2,MINRAM,IA-1,IB,NB,IA-NB) ENDIF ENDIF C C Multiplication: WRITE(*,'(A)') '+MATMUL: Multiplying... ' C IF ((NSPAR1.LT.0).AND.(NSPAR2.LT.0).AND. ccc * ((M1.LT.IB).AND.(M1*M3.LT.IA-M2))) THEN * (IC.GE.MINRAM)) THEN C Multiplication for non-sparse matrices: IC=MINRAM NC=M1*M3 NSPARC=-1 NELC=NC ISYMC=ISYM3 IIKK=IC-1 II1=1 II2=M1 IA1=IA-1 IB1=IB-1 C Loop over columns of C: DO 27, KK=1,M3 WRITE(*,'(2(A,1I9))') '+MATMUL: Multiplying...',KK,' /',M3 C Loop over lines of column KK of matrix C: IF (ISYMC.EQ.1) THEN II1=KK II2=KK ELSEIF (ISYMC.EQ.2) THEN II2=KK ELSEIF (ISYMC.EQ.3) THEN II2=KK-1 ENDIF DO 26, II=II1,II2 IIKK=IIKK+1 CIK=0. DO 25, JJ=1,M2 C Element of the matrix A: IF (ISYM1.EQ.1) THEN IF (II.EQ.JJ) THEN AA=RAM(IA1+JJ) ELSE GOTO 25 ENDIF ELSEIF (ISYM1.EQ.2) THEN IF (II.LE.JJ) THEN AA=RAM(IA1+(JJ-1)*JJ/2+II) ELSE AA=RAM(IA1+(II-1)*II/2+JJ) ENDIF ELSEIF (ISYM1.EQ.3) THEN IF (II.EQ.JJ) THEN GOTO 25 ELSEIF (II.LT.JJ) THEN AA= RAM(IA1+(JJ-1)*(JJ-2)/2+II) ELSE AA=-RAM(IA1+(II-1)*(II-2)/2+JJ) ENDIF ELSE AA=RAM(IA1+(JJ-1)*M1+II) ENDIF C Element of the matrix B: IF (ISYM2.EQ.1) THEN IF (JJ.EQ.KK) THEN BB=RAM(IB1+KK) ELSE GOTO 25 ENDIF ELSEIF (ISYM2.EQ.2) THEN IF (JJ.LE.KK) THEN BB=RAM(IB1+(KK-1)*KK/2+JJ) ELSE BB=RAM(IB1+(JJ-1)*JJ/2+KK) ENDIF ELSEIF (ISYM2.EQ.3) THEN IF (JJ.EQ.KK) THEN GOTO 25 ELSEIF (JJ.LT.KK) THEN BB= RAM(IB1+(KK-1)*(KK-2)/2+JJ) ELSE BB=-RAM(IB1+(JJ-1)*(JJ-2)/2+KK) ENDIF ELSE BB=RAM(IB1+(KK-1)*M2+JJ) ENDIF CIK=CIK+AA*BB 25 CONTINUE RAM(IIKK)=CIK 26 CONTINUE 27 CONTINUE ELSE C Multiplication for the case that at least one matrix is sparse, C or IC is negative (no space for whole matrix C): IC=MINRAM LSPARC=.TRUE. IF (ISYM3.EQ.2) THEN C Symmetric matrix NC=M1*(M1+1)/2 ELSEIF (ISYM3.EQ.3) THEN C Antisymmetric matrix NC=M1*(M1-1)/2 ELSEIF (ISYM3.EQ.1) THEN C Diagonal matrix NC=M1 ELSE C General matrix NC=M1*M3 ENDIF MC=IB-1 NSPARC=-1 NELC=NC ISYMC=ISYM3 C NCTMP=0 ICTMP1=IC-1 DO 50, KK=1,M3 WRITE(*,'(2(A,1I9))') '+MATMUL: Multiplying...',KK,' /',M3 C Preparing sufficient number of the storage locations: C Number NCCOL of storage locations for column KK: IF (ISYMC.EQ.1) THEN NCCOL=1 ELSEIF (ISYMC.EQ.2) THEN NCCOL=KK ELSEIF (ISYMC.EQ.3) THEN NCCOL=KK-1 ELSE NCCOL=M1 ENDIF IF (IC-1+NCTMP+NCCOL.GT.MC) THEN C Erasing unneeded columns 1 to KK-1 of B: IF (NSPAR2.LT.0) THEN C IB stays unchanged, MC is redefined: IF (ISYM2.EQ.1) THEN MC=IB+KK-1-1 ELSEIF (ISYM2.EQ.2) THEN MC=IB+(KK-1)*KK/2-1 ELSEIF (ISYM2.EQ.3) THEN MC=IB+(KK-2)*(KK-1)/2-1 ELSE MC=IB+M2*(KK-1)-1 ENDIF ELSE C IB must be changed, addresses of the ends of the columns C must be moved: IBN=IRAM(IB-1+KK)-(M3+1) DO 28, I1=M3,0,-1 IF (I1.GE.KK-1) THEN IRAM(IBN+I1)=IRAM(IB+I1) ELSE IRAM(IBN+I1)=IRAM(IB-1+KK) ENDIF 28 CONTINUE IB=IBN MC=IB-1 ENDIF IF ((IC-1+NCTMP+NCCOL.GT.MC).AND.(LSPARC)) THEN C Changing the calculated part of C to sparse matrix: CALL GSPART(M1,M3,ISYMC,NSPARC,NELC,MINRAM,IB-1, * IC,NCTMP,KK-1,ICTMP1) ENDIF IF (IC-1+NCTMP+NCCOL.GT.MC) THEN C MATMUL-10 WRITE(TXTERR,'(A,I9,A)') * 'MATMUL-10: Array RAM too small,',IC-1+NCTMP+NCCOL-MC, * ' units missing.' CALL ERROR(TXTERR) ENDIF ENDIF C Initiating the values in column KK of C: DO 29, I1=IC-1+NCTMP+1,IC-1+NCTMP+NCCOL RAM(I1)=0. 29 CONTINUE C Preparing loop over column KK of B: CALL MMILOC(M2,M3,ISYM2,NSPAR2,IB,KK,JJ1,JJ2,JJ3) C Loop over nonzero elements of column KK of B: DO 40, JJA=JJ1,JJ2,JJ3 C Computing index JJ of row and value BB of the element of B: CALL MMIRVE(M2,M3,ISYM2,NSPAR2,IB,KK,JJA,JJ1,JJ3,JJ,BB) C Preparing loop over column JJ of A: CALL MMILOC(M1,M2,ISYM1,NSPAR1,IA,JJ,II1,II2,II3) C Loop over nonzero elements of column JJ of A: DO 32, IIA=II1,II2,II3 C Computing index II of row and value AA of element of A: CALL MMIRVE(M1,M2,ISYM1,NSPAR1,IA,JJ,IIA,II1,II3,II,AA) IF ((ISYMC.EQ.1).AND.(II.EQ.KK)) THEN IIKK=ICTMP1+II ELSEIF ((ISYMC.EQ.2).AND.(II.LE.KK)) THEN IIKK=ICTMP1+(KK-1)*KK/2+II ELSEIF ((ISYMC.EQ.3).AND.(II.LT.KK)) THEN IIKK=ICTMP1+(KK-2)*(KK-1)/2+II ELSEIF (ISYMC.EQ.4) THEN IIKK=ICTMP1+(KK-1)*M1+II ELSE GOTO 30 ENDIF C Multiplying Aij*Bjk: RAM(IIKK)=RAM(IIKK) + AA*BB 30 CONTINUE IF (((ISYM1.EQ.2).OR.(ISYM1.EQ.3)).AND.(II.NE.JJ)) THEN C A is (anti)symmetric, multiplying also Aji=(-)Aij: IF ((ISYMC.EQ.1).AND.(JJ.EQ.KK)) THEN JJKK=ICTMP1+JJ ELSEIF ((ISYMC.EQ.2).AND.(JJ.LE.KK)) THEN JJKK=ICTMP1+(KK-1)*KK/2+JJ ELSEIF ((ISYMC.EQ.3).AND.(JJ.LT.KK)) THEN JJKK=ICTMP1+(KK-2)*(KK-1)/2+JJ ELSEIF (ISYMC.EQ.4) THEN JJKK=ICTMP1+(KK-1)*M1+JJ ELSE GOTO 32 ENDIF IF (ISYM1.EQ.3) AA=-AA BBB=VELEM(M2,M3,ISYM2,NSPAR2,IB,II,KK) C Multiplying Aji*Bik: RAM(JJKK)=RAM(JJKK) + AA*BBB ENDIF 32 CONTINUE IF (((ISYM2.EQ.2).OR.(ISYM2.EQ.3)).AND.(JJ.NE.KK)) THEN C B is (anti)symmetric, multiplying also Bkj=(-)Bjk: IF (ISYM2.EQ.3) BB=-BB C In this case matrix C may not be changed to sparse: LSPARC=.FALSE. C Preparing loop over column KK of A: CALL MMILOC(M1,M2,ISYM1,NSPAR1,IA,KK,II1,II2,II3) C Loop over nonzero elements stored for column KK of A: DO 34, IIA=II1,II2,II3 C Computing index II of row and value AA of element of A: CALL MMIRVE(M1,M2,ISYM1,NSPAR1,IA,KK,IIA,II1,II3,II,AA) IF ((ISYMC.EQ.1).AND.(II.EQ.JJ)) THEN IIJJ=ICTMP1+II ELSEIF ((ISYMC.EQ.2).AND.(II.LE.JJ)) THEN IIJJ=ICTMP1+(JJ-1)*JJ/2+II ELSEIF ((ISYMC.EQ.3).AND.(II.LT.JJ)) THEN IIJJ=ICTMP1+(JJ-2)*(JJ-1)/2+II ELSEIF (ISYMC.EQ.4) THEN IIJJ=ICTMP1+(JJ-1)*M1+II ELSE GOTO 34 ENDIF C Multiplying Aik*Bkj: RAM(IIJJ)=RAM(IIJJ) + AA*BB 34 CONTINUE C If A is (anti)symmetric dense, multiplying the rest C of column KK of A under the diagonal. C (Here B is (anti)symmetric and thus A cannot be C (anti)symmetric sparse.) IF ((ISYM1.EQ.2).OR.(ISYM1.EQ.3)) THEN DO 36, II=KK+1,M1 IF ((ISYMC.EQ.1).AND.(II.EQ.JJ)) THEN IIJJ=ICTMP1+II ELSEIF ((ISYMC.EQ.2).AND.(II.LE.JJ)) THEN IIJJ=ICTMP1+(JJ-1)*JJ/2+II ELSEIF ((ISYMC.EQ.3).AND.(II.LT.JJ)) THEN IIJJ=ICTMP1+(JJ-2)*(JJ-1)/2+II ELSEIF (ISYMC.EQ.4) THEN IIJJ=ICTMP1+(JJ-1)*M1+II ELSE GOTO 36 ENDIF IF (ISYM1.EQ.2) THEN C Aik=Aki AA=RAM(IA-1+(II-1)*II/2+KK) C Multiplying Aik*Bkj: RAM(IIJJ)=RAM(IIJJ) + AA*BB ELSE C Aik=-Aki AA=-RAM(IA-1+(II-1)*(II-2)/2+KK) C Multiplying Aik*Bkj: RAM(IIJJ)=RAM(IIJJ) + AA*BB ENDIF 36 CONTINUE ENDIF ENDIF 40 CONTINUE NCTMP=NCTMP+NCCOL 50 CONTINUE IF (NSPARC.GE.0) THEN C Changing the remaining part of C to sparse matrix: CALL GSPART(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM, * IC,NCTMP,M3,ICTMP1) ENDIF ENDIF C 100 CONTINUE C IF ((ISPAR3.EQ.1).AND.(NSPARC.LT.0)) THEN C Changing non-sparse matrix to sparse matrix: CALL GSMATR(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM,IC,NC) ELSEIF ((ISPAR3.EQ.-1).AND.(NSPARC.GE.0)) THEN C Changing sparse matrix to non-sparse matrix: CALL SGMATR(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM,IC,NC) ELSEIF (ISPAR3.EQ.0) THEN C Automatic selection of the sparseness: IF (NSPARC.LT.0) THEN C Matrix is non-sparse, it will be changed to sparse if its C sparseness is 0.5 or more: RSPAR3=0.5 CALL GSMAT(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM,IC,NC,RSPAR3) ELSE C Matrix is sparse. RSPAR3=FLOAT(NSPARC)/FLOAT(NSPARC+NELC) IF (RSPAR3.LT.0.5) THEN C Matrix is sparse, sparseness is less than 0.5, thus changing C the sparse matrix to non-sparse matrix: CALL SGMATR(M1,M3,ISYMC,NSPARC,NELC,MINRAM,MAXRAM,IC,NC) ENDIF ENDIF ENDIF C C Writing output matrix C: SPARSC=' ' IF (NSPARC.GE.0) SPARSC='CSC' CALL WMATH(LU1,FILE3,FILED3,M1,M3,SPARSC,NELC,SYM3,FORM3) CALL WMATD(LU1,FILED3,M1,M3,SPARSC,NELC,FORM3,IC) C WRITE(*,'(A)') '+MATMUL: Done. ' C STOP END C C======================================================================= C C C SUBROUTINE MMILOC(M1,M2,ISYM,NSPARS,IA,ICOLUM, * IELEM1,IELEM2,IELEM3) INTEGER M1,M2,ISYM,NSPARS,IA,ICOLUM,IELEM1,IELEM2,IELEM3 C C Subroutine designed to Initiate Loop Over Column ICOLUM of a matrix. C C Input: C M1 ... Number of rows of the matrix. C M2 ... Number of columns of the matrix. C ISYM... Index of the symmetry of the matrix. C NSPARS..Sparseness of the matrix. C IA ... Address of the first storage location of the matrix. C ICOLUM..Number of the column under considertation. C For detailed description of storage of matrices in the memory C refer to file mat.for. C C Output: C IELEM1..Address of the value of the first element of column ICOLUM C in array ARRAY. C IELEM2..Address of the value of the last element of column ICOLUM C in array ARRAY. C IELEM3..Step between two consecutive values of the matrix elements C in array ARRAY. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix. C....................................................................... C C Preparing loop over column ICOLUM of the matrix: IF (NSPARS.GE.0) THEN IELEM1=IRAM(IA-1+ICOLUM)+1 IELEM2=IRAM(IA+ICOLUM)-1 IELEM3=2 ELSE IF (ISYM.EQ.1) THEN IELEM1=IA+ICOLUM-1 IELEM2=IELEM1 IELEM3=1 ELSEIF (ISYM.EQ.2) THEN IELEM1=IA+(ICOLUM-1)*ICOLUM/2 IELEM2=IELEM1+M1-1 IELEM3=1 ELSEIF (ISYM.EQ.3) THEN IELEM1=IA+(ICOLUM-1)*(ICOLUM-2)/2 IELEM2=IELEM1+M1-1 IELEM3=1 ELSE IELEM1=IA+(ICOLUM-1)*M1 IELEM2=IELEM1+M1-1 IELEM3=1 ENDIF ENDIF RETURN END C C======================================================================= C C C SUBROUTINE MMIRVE(M1,M2,ISYM,NSPARS,IA,ICOLUM, * IELEMA,IELEM1,IELEM3, * IROW,VELEM) INTEGER M1,M2,ISYM,NSPARS,IA,ICOLUM,IELEMA,IELEM1,IELEM3,IROW REAL VELEM C C Subroutine designed to calculate Index of Row and Value of Element C of a matrix. C C Input: C M1 ... Number of rows of the matrix. C M2 ... Number of columns of the matrix. C ISYM... Index of the symmetry of the matrix. C NSPARS. Sparseness of the matrix. C IA ... Address of the first storage location of the matrix. C ICOLUM..Number of the column under consideration. C IELEMA..Address of the value of the current element of column C ICOLUM in array RAM. C IELEM1..Address of the value of the first element of column ICOLUM C in array RAM. C IELEM3..Step between two consecutive values of the matrix elements C in array RAM. C For detailed description of storage of matrices in the memory C refer to file mat.for. C C Output: C IROW .. Number of the row corresponding to the matrix element C under considertation. C VELEM...Value of the considered matrix element. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix. C....................................................................... C C Calculating index IROW of row of the matrix: IF (NSPARS.GE.0) THEN IROW=IRAM(IELEMA-1) ELSE IF (ISYM.EQ.1) THEN IROW=ICOLUM ELSE IROW=(IELEMA-IELEM1+IELEM3)/IELEM3 ENDIF ENDIF C Calculating the value VELEM of element of the matrix: IF (NSPARS.GE.0) THEN VELEM=RAM(IELEMA) ELSE IF (ISYM.EQ.2) THEN C 'sym' IF (IROW.LE.ICOLUM) THEN VELEM=RAM(IELEMA) ELSE VELEM=RAM(IA-1+(IROW-1)*IROW/2+ICOLUM) ENDIF ELSEIF (ISYM.EQ.3) THEN C 'skew' IF (IROW.LT.ICOLUM) THEN VELEM=RAM(IELEMA) ELSEIF (IROW.EQ.ICOLUM) THEN VELEM=0. ELSE VELEM=-RAM(IA-1+(IROW-1)*(IROW-2)/2+ICOLUM) ENDIF ELSE C 'diag' or ' ' VELEM=RAM(IELEMA) ENDIF ENDIF RETURN END C C======================================================================= C C C SUBROUTINE OMULS(M1C,ISYMC,M1,M2,ISYM,NSPAR,NELEM, * MIA,MAA,IA,NA,IC) INTEGER M1C,ISYMC,M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IC C C Subroutine to estimate optimum origin IC where to write matrix C, C assuming that matrix B given to OMUL will be stored as sparse matrix, C and will be stored so that it will terminate at the same position C where it terminates now. C IC is estimated as minimum over KK=1,M2 of End(KK-1)-M2-AllKKC, C where End(KK-1) is the address of end of row KK-1 of matrix B if C matrix B were stored as sparse matrix in the form "as in the memory", C and AllKKC is the number of elements of columns 1 to KK of matrix C. C C Input: C M1C ... Number of rows of matrix C. C ISYMC.. Index of symmetry of matrix C. C M1... Number of rows of matrix B. C M2... Number of columns of matrix B. C ISYM .. Index of symmetry of matrix B. C NSPAR...Sparseness of matrix B. C NELEM...Number of elements of matrix B. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. C IA ... Address of the first storage location of matrix B. C NA ... Number of storage locations of matrix B. C For detailed description of storage of matrices in the memory C refer to file mat.for. C C Output: C IC ... Address of the origin where to write matrix C. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,NELMAT INTEGER NELMAT C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER II,KK,JJ,NN,JB,II1,II2,ITMP C C....................................................................... C IF (NSPAR.LT.0) THEN C Calculating addresses of ends of columns of B if B were stored C as sparse matrix ending at the same position where it ends now: ITMP=IA-M2-1 IF (ITMP.LE.MIA) THEN C There is no space for ends of rows, thus IC is put to -1: IC=-1 RETURN ENDIF JB=IA+NA-1 JJ=JB IRAM(ITMP+M2)=JJ+1 II1=1 II2=M1 C Loop over columns of B: DO 12, KK=M2,1,-1 C Loop over lines of B: IF (ISYM.EQ.1) THEN II1=KK II2=KK ELSEIF (ISYM.EQ.2) THEN II2=KK ELSEIF (ISYM.EQ.3) THEN II2=KK-1 ENDIF C Number NN of nonzero elements of column KK: NN=0 DO 10, II=II1,II2 IF (RAM(JB).NE.0.) NN=NN+1 JB=JB-1 10 CONTINUE JJ=JJ-2*NN IRAM(ITMP+KK-1)=JJ+1 12 CONTINUE ELSE ITMP=IA ENDIF IC=ITMP DO 20, KK=1,M2 IC=MIN0(IC,IRAM(ITMP-1+KK)-M2-1-NELMAT(M1C,KK,ISYMC)) 20 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE OMULNS(M1C,ISYMC,M1,M2,ISYM,NSPAR,NELEM, * MIA,MAA,IA,NA,IC) INTEGER M1C,ISYMC,M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,IC C C Subroutine to estimate optimum origin IC where to write matrix C, C assuming that matrix B given to OMULNS will be stored as non-sparse C matrix, and will be stored so that it will terminate at the same C position where it terminates now. C IC is estimated as minimum over KK=1,M2 of End(KK-1)-AllKKC+1, C where End(KK-1) is the address of end of row KK-1 of matrix B if C matrix B were stored as non-sparse matrix, C and AllKKC is the number of elements of columns 1 to KK of matrix C. C C Input: C M1C ... Number of rows of matrix C. C ISYMC.. Index of symmetry of matrix C. C M1... Number of rows of matrix B. C M2... Number of columns of matrix B. C ISYM .. Index of symmetry of matrix B. C NSPAR...Sparseness of matrix B. C NELEM...Number of elements of matrix B. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. C IA ... Address of the first storage location of matrix B. C NA ... Number of storage locations of matrix B. C For detailed description of storage of matrices in the memory C refer to file mat.for. C C Output: C IC ... Origin where to write matrix C. C C Coded by Petr Bulant C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL NELMAT INTEGER NELMAT C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER KK,ITMP C C....................................................................... C IF (NSPAR.LT.0) THEN ITMP=IA ELSE ITMP=IA+NA-NELMAT(M1,M2,ISYM) ENDIF IC=ITMP DO 20, KK=1,M2 IC=MIN0(IC,ITMP+NELMAT(M1,KK-1,ISYM)-NELMAT(M1C,KK,ISYMC)) 20 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE GSPART(M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,ICOL,ITMP) INTEGER M1,M2,ISYM,NSPAR,NELEM,MIA,MAA,IA,NA,ICOL,ITMP C C Subroutine designed to consecutively change parts of non-sparse matrix C to the sparse matrix. For the first invocation, it is assumed on input C that non-sparse part of the matrix for columns 1 to ICOL is stored C in RAM, and this part is changed to sparse matrix and written C to RAM and IRAM together with M2+1 addresses of beginnings C of columns. For second and other invocations, it is assumed that C IRAM and RAM contain M2+1 addresses of beginnings of columns of the C sparse part of the matrix, followed by the sparse part of the matrix C (columns 1 to ICOL0), and finally by non-sparse part of the matrix C (columns ICOL0+1 to ICOL). The non-sparse part is converted to the C sparse and written after the already stored sparse part, and the C addressses of columns ICOL0+1 to M2+1 are updated. C C Input: C M1... Number of rows of the full matrix. C M2... Number of columns of the full matrix. C ISYM ...Index of symmetry of the matrix. C SYM='diag' ... ISYM=1 C SYM='sym' ... ISYM=2 C SYM='skew' ... ISYM=3 C SYM=' ' ... ISYM=4 C NSPAR...Sparseness of the matrix. C NELEM...Number of elements of the matrix stored in array RAM. C MIA,MAA ... Minimum and maximum address of arrays (I)RAM C available for the subroutine. Entire arrays (I)RAM C from MIA to MAA may be used for temporary storage. C IA ... Address of the first storage location in array RAM C used for the matrix. C NA ... Number of storage locations for the input matrix. C ICOL ...Index of the last calculated column of the matrix. C C Output: C NSPAR...Sparseness of the M1*ICOL matrix. C NELEM...Number of elements of the M1*ICOL matrix. C NA ... New number of storage locations for the M1*ICOL matrix. C ITMP ...Fictitious position in RAM just before the first storage C location of the matrix if the matrix would stay non-sparse C and would terminate at the same location where it C terminates after its conversion to the sparse matrix. C C Coded by Petr Bulant C E-mail: bulant@seis.karlov.mff.cuni.cz C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,NSPMAT,NELMAT INTEGER NSPMAT,NELMAT C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C IRAM,RAM...Indices of elements and elements of the matrix, see C the detailed description of storage of matrices in C the memory given above. C C Local storage location: INTEGER I1,I2,I3,I4,I11,I12,IAR,IAS,NAR,NSPA,NELE,ICOL0,ISHIFT CHARACTER*72 TXTERR SAVE ICOL0 DATA ICOL0/0/ C C....................................................................... C C Beginning IAR and number of elements NAR of the non-sparse part C of RAM: IF (ICOL0.EQ.0) THEN IAR=IA NAR=NA ELSE IAR=IRAM(IA+M2) NAR=NA-(IAR-IA) ENDIF C Number NSPA of zero and NELE of nonzero elements: NSPA=NSPMAT(NAR,RAM(IAR)) NELE=NAR-NSPA IF (((ICOL0.EQ.0).AND.(IAR+M2+1+2*NELE.GT.MAA)).OR. * ((ICOL0.NE.0).AND.(IAR+ 2*NELE.GT.MAA))) THEN C MATMUL-12 IF (ICOL0.EQ.0) THEN I1=IAR+M2+1+2*NELE - MAA ELSE I1=IAR+ 2*NELE - MAA ENDIF WRITE(TXTERR,'(A,I9,A)') * 'MATMUL-12: Array RAM too small,',I1,' units missing.' CALL ERROR(TXTERR) ENDIF C Moving the dense part of the matrix to the end of available RAM: DO 10, I1=0,NAR-1 RAM(MAA-I1)=RAM(IAR+NAR-1-I1) 10 CONTINUE IAR=MAA-(NAR-1) C Beginning IAS where to write the new sparse part of the matrix, C shifting index ISHIFT for case of ICOL0.eq.0: IF (ICOL0.EQ.0) THEN IAS=IA+ICOL+1 ISHIFT=M2+1-(ICOL+1) IRAM(IA)=IAS+ISHIFT ELSE IAS=IRAM(IA+M2) ISHIFT=0 ENDIF C Moving the nonzero elements of the matrix, C storing their row indices, recording column indices: I3=IAR I4=IAS C I3 points to the dense array, C I4 points to the new part of the sparse array DO 20, I2=ICOL0+1,ICOL IF (ISYM.EQ.1) THEN I12=I2 I11=I2 ELSEIF (ISYM.EQ.2) THEN I12=I2 I11=1 ELSEIF (ISYM.EQ.3) THEN I12=I2-1 I11=1 ELSE I12=M1 I11=1 ENDIF DO 18, I1=I11,I12 IF (RAM(I3).NE.0.) THEN IF (I4+1.LE.I3) THEN C MATMUL-13 CALL ERROR('MATMUL-13: Array RAM too small') C The output matrix is being formed in the memory, C but there was not enough space in RAM for it. C Thus the already formed part of the matrix is being C converted to the sparse matrix. There is enough space for C the sparse matrix, but the conversion is not possible. C May be that only several more memory locations will solve C the problem, try to enlarge MRAM, if possible. ENDIF IRAM(I4)=I1 RAM(I4+1)=RAM(I3) I4=I4+2 ENDIF I3=I3+1 18 CONTINUE IRAM(IA-1+I2+1)=I4+ISHIFT 20 CONTINUE C C I4 now points just after the last nonzero element IF (ISHIFT.NE.0) THEN C Shifting the sparse part of the matrix: IF (I4+ISHIFT.GT.MAA) THEN C MATMUL-14 WRITE(TXTERR,'(A,I9,A)') 'MATMUL-14: Array RAM too small,', * I4+ISHIFT-MAA,' units missing.' CALL ERROR(TXTERR) ENDIF DO 30, I1=I4-2,IAS,-2 RAM(I1+1+ISHIFT)=RAM(I1+1) IRAM(I1+ISHIFT)=IRAM(I1) 30 CONTINUE ENDIF C C Recording pointers for columns ICOL+2 to M2+1: DO 32, I1=IA-1+ICOL+2,IA-1+M2+1 IRAM(I1)=IRAM(IA-1+ICOL+1) 32 CONTINUE C C ICOL0=ICOL NA=IRAM(IA+M2)-IA NELEM=(NA-M2-1)/2 I1=NELMAT(M1,ICOL,ISYM) NSPAR=I1-NELEM ITMP=IRAM(IA+M2)-1-I1 C 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 'mat.for' C mat.for C C======================================================================= Cmfsd.for 0100666 0000765 0000765 00000007431 10444173574 012110 0 ustar bulant bulant CC 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======================================================================= Cmgrd.for 0100666 0000765 0000765 00000022445 11023416420 012072 0 ustar bulant bulant CC Program MGRD (Multivalued GRiD) to convert multivalued grid into C several singlevalued grids. C C Version: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file 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 EXTERNAL UARRAY REAL UARRAY 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) C UNDEF=UARRAY() 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 C should probably be increased to accommodate the input integer C 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 C should probably be increased to accommodate the input C 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 00000026250 11023416420 012420 0 ustar bulant bulant CC 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 00000111547 11023416420 013001 0 ustar bulant bulant CC 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.90 C Date: 2005, May 10 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 CALCOPS='string'... String with the PostScript instructions, see C file C calcops.for. 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 00000017700 11023416420 012077 0 ustar bulant bulant CC 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 00000015765 11023416420 012453 0 ustar bulant bulant CC 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: 6.00 C Date: 2005, November 12 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 Optional parameters specifying the form of the quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C forms.for. 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 EXTERNAL UARRAY REAL UARRAY C C Filenames and parameters: CHARACTER*80 FSEP,FPTS,FGRD INTEGER LU REAL UNDEF PARAMETER (LU=1) 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 UNDEF=UARRAY() 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 00000044721 11023416420 012475 0 ustar bulant bulant CC Program PTSWRL to convert points into the Virtual Reality Modeling C Language or GOCAD representation C C Version: 6.00 C Date: 2006, June 15 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....................................................................... 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 C 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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,MQ PARAMETER (LU1=1,LU2=2,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 CC 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 00000013541 11023416420 012420 0 ustar bulant bulant CC Auxiliary main program RTCOEF (for testing C 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 00000076276 11023416420 011743 0 ustar bulant bulant CC Subroutine file 'sep.for' to read data in the form of the SEP header C or parameter files. C C Version: 6.20 C Date: 2008, April 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 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,IOLD) INTEGER I,IOLD C C Subroutine designed to switch between different sets of the SEP C parameters. C C Input: C I... Index of the already existing set or a new set to be used, C supplemented with the minus sign if the already stored SEP C parameters of set I should be deleted. C I=0 means that the index of a new (i.e. never used) set is C to be determined by subroutine SSEP. It is reasonable to C let subroutine SSEP to determine the index of a new set. C C Output: C I... If I=0 on input, the index of a new (i.e. never used) set C determined by subroutine SSEP. Otherwise, absolute value C of the input. C Set number I of the SEP parameters will be used until the C next invocation of SSEP. Set number 1 is used before the C first invocation of SSEP. C IOLD... Index of the set of the SEP parameters used before the C invocation of SSEP. C C Examples: C Switching to a new set of the SEP parameters: C I1=0 C CALL SSEP(I1,I2) C Then switching back to the previously used set: C CALL SSEP(I2,I1) C Switching again to set I1 and deleting SEP parameters of set I1: C I1=-I1 C CALL SSEP(I1,I2) C Determining index I2 of the current set of the SEP parameters: C I1=1 C CALL SSEP(I1,I2) C CALL SSEP(I2,I1) C C----------------------------------------------------------------------- C INCLUDE 'sep.inc' C sep.inc C C----------------------------------------------------------------------- C INTEGER I1,ISHIFT C IF(I.EQ.0) THEN I=NSET+1 END IF IF(I.LT.0) THEN I=-I IF(I.LE.NSET) THEN C Deleting SEP parameters of set I ISHIFT=NPAR(I)-NPAR(I-1) DO 11 I1=NPAR(I-1)+1,NPAR(NSET)-ISHIFT PAR(I1) =PAR(I1+ISHIFT) VALUE(I1)=VALUE(I1+ISHIFT) NCHAR(I1)=NCHAR(I1+ISHIFT) 11 CONTINUE DO 12 I1=I,NSET NPAR(I1)=NPAR(I1)-ISHIFT 12 CONTINUE END IF END IF 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 13 I1=NSET+1,I NSET=I1 NPAR(I1)=NPAR(I1-1) 13 CONTINUE END IF IOLD=ISET 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,LENGTH,ERROR INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*255 LINE CHARACTER*72 TXTERR C IF(FILE.NE.' ') THEN OPEN(LU,FILE=FILE,STATUS='OLD',ERR=10) 1 CONTINUE READ(LU,'(A)',END=9) LINE CALL RSEP2(LINE) GO TO 1 9 CONTINUE END IF RETURN 10 CONTINUE C SEP-09 WRITE(TXTERR,'(A,A,A)') 'SEP-09: Error when opening file ''', *FILE(1:MIN0(LENGTH(FILE),37)),'''.' CALL ERROR(TXTERR) 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=13) 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='(G13.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 00000013416 11023416420 011730 0 ustar bulant bulantHistory files History files
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 00000010412 11024410620 011541 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=sgfgrd.for 0100666 0000765 0000765 00000103030 11024140020 012372 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 SGFGRD to calculate the grid values of a real-valued quantity C decomposed into the structural Gabor functions C C Version: 6.20 C Date: 2008, June 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 Two real-valued coefficients stand in for the complex-valued C coefficient of each odd Gabor function. The odd real-valued C coefficient is the real part, and the even real-valued C coefficient is the imaginary part. These two real-valued coefficients C simultaneously represent the complex-valued coefficient of the C successive even Gabor function because the two Gabor functions and C the corresponding complex-valued coefficients are complex-conjugate. C Each odd real-valued coefficient thus corresponds to twice the C real part of the Gabor function of the same odd index, and each even C real-valued coefficient corresponds to twice the imaginary C part of the Gabor function of the same even index. 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 and output files: C SGF='string'... Name of the input file with structural Gabor C functions. Input parameters N1, N2, N3 determine whether C the structural Gabor functions are 1-D, 2-D or 3-D. C The wavemumber components and matrix elements C corresponding to the direction in which the number of C gridpoints is Ni=1 should equal zero. C Description of file SGF. C Default: SGF='sgf.out' C SGFAMP='string'... Name of the header file of the input C real-valued vector of the amplitudes of Gabor functions, C corresponding to a real-valued quantity to be gridded. C For general description of the files with matrices refer C to file forms.htm. C Default: SGFAMP='sgfamp.out' C GRD='string'... Name of the formatted output file with the gridded C real-valued quantity. The file contains N1*N2*N3 values. C For general description of files with gridded data refer C to file forms.htm. C Default: GRD='sgfgrd.out' C Data specifying dimensions of the input grid: C N1,N2,N3=integers... Numbers of gridpoints along the X1,X2,X3 C axes, respectively. These numbers also determine whether C the structural Gabor functions are 1-D, 2-D or 3-D. C Defaults: N1=1, N2=1, N3=1 C O1,O2,O3=reals... Coordinates of the origin of the grid, i.e., C of the first gridpoint. C Defaults: O1=0, O2=0, O3=0 C D1,D2,D3=reals... Grid intervals along the X1,X2,X3 axes, C respectively. C Defaults: D1=1, D2=1, D3=1 C Numerical parameters: C RELAMP=positive real... Relative decay of the Gaussian envelope C at which the loop over the points of the input grid is C terminated. C The relative error due to this economizing roughly C corresponds to the value of RELAMP. C Default: RELAMP=0.001 C Form of the output files with matrices: C FORMM='string' ... Form of the output files with matrices. Allowed C values are FORMM='formatted' and FORMM='unformatted'. C Default: FORMM='formatted' C Optional parameters specifying the form of the quantities C written to the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLIN=positive integer ... Number of reals in one line of the C output file. See the description in file 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 ERROR,RSEP1,RSEP3T,RSEP3I,RSEP3R,RMATH,RMATD C C Constants: REAL COEF1D,COEF2D,COEF3D PARAMETER (COEF1D=1.772453851) PARAMETER (COEF2D=3.141592654) PARAMETER (COEF3D=5.568327997) C C Filenames and parameters: CHARACTER*80 FSEP,FSGF,FAMP,FDAT,FGRD INTEGER LU1 PARAMETER (LU1=1) C C Input data: INTEGER N1,N2,N3,N1N2N3,NQ,NZ,NSGF,NQNSGF,NDIM INTEGER NELEM,M1,M2 REAL O1,O2,O3,D1,D2,D3,RELAMP,RELLOG,ZERO(12) CHARACTER*3 SPARSE CHARACTER*4 SYMM CHARACTER*11 FORM CHARACTER*1 TEXT C C Gabor function b (beta): REAL BX1,BX2,BX3,BK1,BK2,BK3 REAL BY11,BY12,BY22,BY13,BY23,BY33,BYDET REAL BR11,BR12,BR22,BR13,BR23,BR33,BAMPR,BAMPI C 2-D projection of 3-D Gabor function: REAL AX1,AX2,AK1,AK2 REAL AY13,AY23,AY33 REAL AR33 C Coordinate differences: REAL DX1,DX2,DX3 C Calculation of a Gabor function: REAL EXPR,EXPI,C,S C Calculation of scalar product with the given grid: REAL EXP0R,EXP0I,EXP1R,EXP1I,EXP1MR,EXP1MI,EXP2R,EXP2I INTEGER J1,J2,J3,K1,K2,K3 C C Auxiliary variables: INTEGER ISGF,IQ INTEGER I1,I2,I3,I REAL DET,AUX C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+SGFGRD: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C SGFGRD-01 CALL ERROR('SGFGRD-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)') '+SGFGRD: Working... ' C C Reading input and output filenames: CALL RSEP3T('SGF' ,FSGF,'sgf.out') CALL RSEP3T('SGFAMP',FAMP,'sgfamp.out') CALL RSEP3T('GRD' ,FGRD,'sgfgrd.out') IF(FSGF.EQ.' ') THEN C SGFGRD-02 CALL ERROR('SGFGRD-02: Blank name of input file SGF') END IF IF(FAMP.EQ.' ') THEN C SGFGRD-03 CALL ERROR('SGFGRD-03: Blank name of input file AMP') END IF IF(FGRD.EQ.' ') THEN C SGFGRD-04 CALL ERROR('SGFGRD-04: Blank name of input file GRD') END IF C C Reading other input SEP parameters: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O1',O1,0.0) CALL RSEP3R('O2',O2,0.0) CALL RSEP3R('O3',O3,0.0) CALL RSEP3R('D1',D1,1.0) CALL RSEP3R('D2',D2,1.0) CALL RSEP3R('D3',D3,1.0) N1N2N3=N1*N2*N3 CALL RSEP3R('RELAMP',RELAMP,0.001) RELLOG=-ALOG(RELAMP) C C Determination of NDIM: C 1-D: NDIM=1,2,3 C 2-D: NDIM=4,5,6 C 3-D: NDIM=7 NDIM=-1 IF(N1.GT.1) NDIM=NDIM+2 IF(N2.GT.1) NDIM=NDIM+3 IF(N3.GT.1) NDIM=NDIM+4 IF(NDIM.EQ.-1) THEN C SGFGRD-05 CALL ERROR('SGFGRD-05: N1=N2=N3=1 is not allowed') END IF IF(NDIM.EQ.2) THEN N1=N2 N2=1 O1=O2 D1=D2 ELSE IF(NDIM.EQ.3) THEN N1=N3 N3=1 O1=O3 D1=D3 ELSE IF(NDIM.EQ.5) THEN N2=N3 N3=1 O2=O3 D2=D3 ELSE IF(NDIM.EQ.6) THEN N1=N2 N2=N3 N3=1 O1=O2 O2=O3 D1=D2 D2=D3 ELSE IF(NDIM.EQ.8) THEN NDIM=7 END IF C C Determination of NQ and NZ: C NQ is the number of reals stored for each Gabor function C NZ is the number of input zeros for each Gabor function IF(NDIM.LE.3) THEN C 1-D NQ=6 NZ=12 ELSE IF(NDIM.LE.6) THEN C 2-D NQ=12 NZ=7 ELSE C 3-D: NQ=20 NZ=0 END IF C C Reading the input vector of the amplitudes of Gabor functions: CALL RMATH(LU1,FAMP,FDAT,M1,M2,SPARSE,NELEM,SYMM,FORM) IF(SPARSE.NE.' ') THEN C SGFGRD-06 CALL ERROR('SGFGRD-06: Input vector is sparse') END IF IF(M2.NE.1.OR.SYMM.NE.' '.OR.NELEM.NE.M1) THEN C SGFGRD-07 CALL ERROR('SGFGRD-07: Input vector is not a vector') END IF IF(NQ*(M1/2+1).GT.MRAM) THEN C SGFGRD-08 CALL ERROR * ('SGFGRD-08: Too small array RAM for Gabor functions') C The input parameters of Gabor functions do not fit into array C RAM(MRAM). C The number of parameters of each Gabor function is C 1-D: NQ=6 C 2-D: NQ=12 C 3-D: NQ=20 END IF CALL RMATD(LU1,FDAT,1,SPARSE,NELEM,FORM,1) DO 1 ISGF=M1/2,1,-1 I1=2*ISGF I2=NQ*ISGF RAM(I2-1)=RAM(I1-1) RAM(I2) =RAM(I1) 1 CONTINUE C C Reading the Gabor functions: OPEN(LU1,FILE=FSGF,FORM='FORMATTED',STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) NQNSGF=0 10 CONTINUE IF(NQNSGF+NQ.GT.MRAM) THEN C SGFGRD-09 CALL ERROR * ('SGFGRD-09: Too small array RAM for Gabor functions') C The input parameters of Gabor functions do not fit into array C RAM(MRAM). C The number of parameters of each Gabor function is C 1-D: NQ=6 C 2-D: NQ=14 C 3-D: NQ=24 END IF TEXT='$' GO TO (11,12,13,14,15,16,17) NDIM C SGFGRD-10 CALL ERROR('SGFGRD-10: Wrong value of NDIM') 11 CONTINUE READ(LU1,*,END=20) TEXT,RAM(NQNSGF+1),AUX,AUX, * RAM(NQNSGF+2),ZERO(1),ZERO(2), * RAM(NQNSGF+3),(ZERO(I),I=3,7), * RAM(NQNSGF+4),(ZERO(I),I=8,12) GO TO 18 12 CONTINUE READ(LU1,*,END=20) TEXT,AUX,RAM(NQNSGF+1),AUX, * ZERO(1),RAM(NQNSGF+2),(ZERO(I),I=2,4), * RAM(NQNSGF+3),(ZERO(I),I=5,9), * RAM(NQNSGF+4),(ZERO(I),I=10,12) GO TO 18 13 CONTINUE READ(LU1,*,END=20) TEXT,AUX,AUX,RAM(NQNSGF+1), * ZERO(1),ZERO(2),RAM(NQNSGF+2),(ZERO(I),I=3,7), * RAM(NQNSGF+3),(ZERO(I),I=8,12), * RAM(NQNSGF+4) GO TO 18 14 CONTINUE READ(LU1,*,END=20) TEXT,RAM(NQNSGF+1),RAM(NQNSGF+2),AUX, * RAM(NQNSGF+3),RAM(NQNSGF+4),ZERO(1), * RAM(NQNSGF+5),RAM(NQNSGF+6),RAM(NQNSGF+7), * (ZERO(I),I=2,4), * RAM(NQNSGF+8),RAM(NQNSGF+9),RAM(NQNSGF+10), * (ZERO(I),I=5,7) GO TO 18 15 CONTINUE READ(LU1,*,END=20) TEXT,RAM(NQNSGF+1),AUX,RAM(NQNSGF+2), * RAM(NQNSGF+3),ZERO(1),RAM(NQNSGF+4), * RAM(NQNSGF+5),ZERO(2),ZERO(3), * RAM(NQNSGF+6),ZERO(4),RAM(NQNSGF+7), * RAM(NQNSGF+8),ZERO(5),ZERO(6), * RAM(NQNSGF+9),ZERO(7),RAM(NQNSGF+10) GO TO 18 16 CONTINUE READ(LU1,*,END=20) TEXT,AUX,RAM(NQNSGF+1),RAM(NQNSGF+2), * ZERO(1),RAM(NQNSGF+3),RAM(NQNSGF+4), * ZERO(2),ZERO(3),RAM(NQNSGF+5), * ZERO(4),RAM(NQNSGF+6),RAM(NQNSGF+7), * ZERO(5),ZERO(6),RAM(NQNSGF+8), * ZERO(7),RAM(NQNSGF+9),RAM(NQNSGF+10) GO TO 18 17 CONTINUE READ(LU1,*,END=20) TEXT,(RAM(I),I=NQNSGF+1,NQNSGF+18) GO TO 18 18 CONTINUE IF(TEXT.EQ.'$') GO TO 20 NQNSGF=NQNSGF+NQ DO 19 I=1,NZ IF(ZERO(I).NE.0.0) THEN C SGFGRD-11 CALL ERROR ('SGFGRD-11: Non-zero input quantity') C The input wavemumber components and matrix elements C corresponding to the direction in which the number of C gridpoints is Ni=1 should equal zero. END IF 19 CONTINUE GO TO 10 20 CONTINUE CLOSE(LU1) NSGF=NQNSGF/NQ IF(M1.NE.2*NSGF) THEN C SGFGRD-12 CALL ERROR('SGFGRD-12: Wrong length of the input vector') END IF C NSGF is the number of odd Gabor functions. C RAM(1:NQNSGF) contain the parameters of odd Gabor functions. C C Checking the positive definiteness of the real part of matrix K, C calculating the squares of maximum differences between coordinates C and wavenumber components, and halving the components of matrix K: IF(NDIM.LE.3) THEN C 1-D: DO 32 I=0,NQNSGF-NQ,NQ IF(RAM(I+3).LE.0.0) THEN C SGFGRD-13 CALL ERROR('SGFGRD-13: Indefinite real part of matrix K') END IF C Halving the components of matrix K DO 31 I1=I+3,I+4 RAM(I1)=0.5*RAM(I1) 31 CONTINUE 32 CONTINUE ELSE IF(NDIM.LE.6) THEN C 2-D: DO 42 I=0,NQNSGF-NQ,NQ DET=RAM(I+5)*RAM(I+7)-RAM(I+6)**2 IF(RAM(I+5).LE.0.0.OR.DET.LE.0.0) THEN C SGFGRD-14 CALL ERROR('SGFGRD-14: Indefinite real part of matrix K') END IF C Halving the components of matrix K DO 41 I1=I+5,I+10 RAM(I1)=0.5*RAM(I1) 41 CONTINUE 42 CONTINUE ELSE C 3-D: DO 52 I=0,NQNSGF-NQ,NQ C Matrix Y BY11=RAM(I+7) BY12=RAM(I+8) BY22=RAM(I+9) BY13=RAM(I+10) BY23=RAM(I+11) BY33=RAM(I+12) C Matrix R BR11=-RAM(I+13) BR12=-RAM(I+14) BR22=-RAM(I+15) BR13=-RAM(I+16) BR23=-RAM(I+17) BR33=-RAM(I+18) C Last column of inverse matrix to Y multiplied by det(Y) AY13=BY12*BY23-BY13*BY22 AY23=BY12*BY13-BY23*BY11 AY33=BY11*BY22-BY12*BY12 C det(Y) BYDET=BY13*AY13+BY23*AY23+BY33*AY33 IF(BY11.LE.0.0.OR.AY33.LE.0.0.OR.BYDET.LE.0.0) THEN C SGFGRD-15 CALL ERROR('SGFGRD-15: Indefinite real part of matrix K') END IF C Halving the components of matrix K DO 51 I1=I+7,I+18 RAM(I1)=0.5*RAM(I1) 51 CONTINUE 52 CONTINUE END IF C C Check for the memory required for the calculation of the grid: IF(NQNSGF+N1N2N3.GT.MRAM) THEN C SGFGRD-16 CALL ERROR('SGFGRD-16: Too small array RAM for the grid') C The input parameters of Gabor functions and the input grid do C not fit together into array C RAM(MRAM). C The number of grid values is N1*N2*N3. C The number of parameters of each Gabor function is C 1-D: NQ=6 C 2-D: NQ=12 C 3-D: NQ=20 END IF C C Initializing the grid values: I=NQNSGF DO 103 I3=1,N3 DO 102 I2=1,N2 DO 101 I1=1,N1 I=I+1 RAM(I)=0.0 101 CONTINUE 102 CONTINUE 103 CONTINUE C C....................................................................... C C Calculating the grid values: IF(NDIM.LE.3) THEN C 1-D: DO 214 ISGF=0,NSGF-1 IF(MOD(ISGF,50).EQ.0) THEN WRITE(*,'(2(A,I7))') * '+SGFGRD: Gabor function',2*ISGF,' /',2*NSGF END IF IQ=NQ*ISGF IF(RAM(IQ+5).NE.0.0.OR.RAM(IQ+5).NE.0.0) THEN C Quantities describing the Gabor function BX1=RAM(IQ+1) BK1=RAM(IQ+2) C Half matrix Y BY11=RAM(IQ+3) C Half matrix R BR11=-RAM(IQ+4) C Determinant of half matrix Y BYDET=BY11 C Amplitude coefficients AUX=2.0*SQRT(SQRT(4.0*BYDET)/COEF2D) BAMPR=AUX*RAM(IQ+5) BAMPI=AUX*RAM(IQ+6) C Extent of the Gabor function along axis X1 AUX=SQRT(RELLOG/BY11) J1=MAX0(INT((BX1-AUX)/D1+0.999),0) K1=MIN0(INT((BX1+AUX)/D1+0.001),N1-1) IF(J1.LE.K1) THEN C Index of the central point along the gridline M1=MAX0(J1,MIN0(NINT(BX1/D1),K1)) C Relative coordinate of the central point DX1=O1+D1*FLOAT(M1)-BX1 C Exponent at the central point EXP0R=DX1*BY11*DX1 EXP0I=DX1*(BK1+BR11*DX1) C The first derivative of the exponent EXP1R=BY11*DX1 EXP1I=BR11*DX1 EXP1R=D1*(EXP1R+EXP1R) EXP1I=D1*(EXP1I+EXP1I+BK1) C Half the second derivative of the exponent EXP2R=D1*BY11*D1 EXP2I=D1*BR11*D1 C Half the second derivative minus the first derivative EXP1MR=EXP2R-EXP1R EXP1MI=EXP2I-EXP1I C Half the second derivative plus the first derivative EXP1R=EXP2R+EXP1R EXP1I=EXP2I+EXP1I C Second derivative of the exponent EXP2R=EXP2R+EXP2R EXP2I=EXP2I+EXP2I C Exponential function at the central point AUX=EXP(-EXP0R) C=COS(EXP0I) S=SIN(EXP0I) EXP0R=C*AUX EXP0I=S*AUX C Exponential correction at the central point (+) AUX=EXP(-EXP1R) C=COS(EXP1I) S=SIN(EXP1I) EXP1R=C*AUX EXP1I=S*AUX C Exponential correction at the central point (-) AUX=EXP(-EXP1MR) C=COS(EXP1MI) S=SIN(EXP1MI) EXP1MR=C*AUX EXP1MI=S*AUX C Constant correction to the correction AUX=EXP(-EXP2R) C=COS(EXP2I) S=SIN(EXP2I) EXP2R=C*AUX EXP2I=S*AUX C C Contribution to the integral at the central point I=NQNSGF+1+M1 RAM(I)=RAM(I)+BAMPR*EXP0R-BAMPI*EXP0I C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Loop over the gridpoints DO 210 I1=I+1,I+K1-M1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX RAM(I1)=RAM(I1)+BAMPR*EXPR-BAMPI*EXPI 210 CONTINUE C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Exponential correction at the central point EXP1R=EXP1MR EXP1I=EXP1MI C Loop over the gridpoints DO 211 I1=I-1,I+J1-M1,-1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX RAM(I1)=RAM(I1)+BAMPR*EXPR-BAMPI*EXPI 211 CONTINUE END IF END IF 214 CONTINUE ELSE IF(NDIM.LE.6) THEN C 2-D: DO 224 ISGF=0,NSGF-1 IF(MOD(ISGF,50).EQ.0) THEN WRITE(*,'(2(A,I7))') * '+SGFGRD: Gabor function',2*ISGF,' /',2*NSGF END IF IQ=NQ*ISGF IF(RAM(IQ+11).NE.0.0.OR.RAM(IQ+12).NE.0.0) THEN C Quantities describing the Gabor function BX1=RAM(IQ+1) BX2=RAM(IQ+2) BK1=RAM(IQ+3) BK2=RAM(IQ+4) C Half matrix Y BY11=RAM(IQ+5) BY12=RAM(IQ+6) BY22=RAM(IQ+7) C Half matrix R BR11=-RAM(IQ+8) BR12=-RAM(IQ+9) BR22=-RAM(IQ+10) C Determinant of half matrix Y BYDET=BY11*BY22-BY12*BY12 C Amplitude coefficients AUX=2.0*SQRT(SQRT(4.0*BYDET)/COEF2D) BAMPR=AUX*RAM(IQ+11) BAMPI=AUX*RAM(IQ+12) C Extent of the Gabor function along axis X2 AUX=SQRT(RELLOG/(BY22-BY12*BY12/BY11)) J2=MAX0(INT((BX2-AUX-O2)/D2+0.999),0) K2=MIN0(INT((BX2+AUX-O2)/D2+0.001),N2-1) DO 222 I2=J2,K2 DX2=O2+D2*FLOAT(I2)-BX2 C Extent of the Gabor function along axis X1 AUX=RELLOG-BY22*DX2*DX2 IF(AUX.GE.0.0) THEN C Halfwidth of the Gabor function along axis X1 AUX=SQRT(AUX/BY11) C Central point along the gridline DX1=BX1-BY12*DX2/BY11-O1 J1=MAX0(INT((DX1-AUX)/D1+0.999),0) K1=MIN0(INT((DX1+AUX)/D1+0.001),N1-1) IF(J1.LE.K1) THEN C Index of the central point along the gridline M1=MAX0(J1,MIN0(NINT(DX1/D1),K1)) C Relative coordinate of the central point DX1=O1+D1*FLOAT(M1)-BX1 C Exponent at the central point EXP0R=DX1*(BY11*DX1+2.0*BY12*DX2)+DX2*BY22*DX2 EXP0I= DX1*(BK1+BR11*DX1+2.0*BR12*DX2) EXP0I=EXP0I+DX2*(BK2+BR22*DX2) C The first derivative of the exponent EXP1R=BY11*DX1+BY12*DX2 EXP1I=BR11*DX1+BR12*DX2 EXP1R=D1*(EXP1R+EXP1R) EXP1I=D1*(EXP1I+EXP1I+BK1) C Half the second derivative of the exponent EXP2R=D1*BY11*D1 EXP2I=D1*BR11*D1 C Half the second derivative minus the first derivative EXP1MR=EXP2R-EXP1R EXP1MI=EXP2I-EXP1I C Half the second derivative plus the first derivative EXP1R=EXP2R+EXP1R EXP1I=EXP2I+EXP1I C Second derivative of the exponent EXP2R=EXP2R+EXP2R EXP2I=EXP2I+EXP2I C Exponential function at the central point AUX=EXP(-EXP0R) C=COS(EXP0I) S=SIN(EXP0I) EXP0R=C*AUX EXP0I=S*AUX C Exponential correction at the central point (+) AUX=EXP(-EXP1R) C=COS(EXP1I) S=SIN(EXP1I) EXP1R=C*AUX EXP1I=S*AUX C Exponential correction at the central point (-) AUX=EXP(-EXP1MR) C=COS(EXP1MI) S=SIN(EXP1MI) EXP1MR=C*AUX EXP1MI=S*AUX C Constant correction to the correction AUX=EXP(-EXP2R) C=COS(EXP2I) S=SIN(EXP2I) EXP2R=C*AUX EXP2I=S*AUX C C Contribution to the integral at the central point I=NQNSGF+1+M1+N1*I2 RAM(I)=RAM(I)+BAMPR*EXP0R-BAMPI*EXP0I C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Loop over the gridpoints DO 220 I1=I+1,I+K1-M1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX RAM(I1)=RAM(I1)+BAMPR*EXPR-BAMPI*EXPI 220 CONTINUE C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Exponential correction at the central point EXP1R=EXP1MR EXP1I=EXP1MI C Loop over the gridpoints DO 221 I1=I-1,I+J1-M1,-1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX RAM(I1)=RAM(I1)+BAMPR*EXPR-BAMPI*EXPI 221 CONTINUE END IF END IF 222 CONTINUE END IF 224 CONTINUE ELSE C 3-D: DO 234 ISGF=0,NSGF-1 IF(MOD(ISGF,50).EQ.0) THEN WRITE(*,'(2(A,I7))') * '+SGFGRD: Gabor function',2*ISGF,' /',2*NSGF END IF IQ=NQ*ISGF IF(RAM(IQ+19).NE.0.0.OR.RAM(IQ+20).NE.0.0) THEN C Quantities describing the Gabor function BX1=RAM(IQ+1) BX2=RAM(IQ+2) BX3=RAM(IQ+3) BK1=RAM(IQ+4) BK2=RAM(IQ+5) BK3=RAM(IQ+6) C Half matrix Y BY11=RAM(IQ+7) BY12=RAM(IQ+8) BY22=RAM(IQ+9) BY13=RAM(IQ+10) BY23=RAM(IQ+11) BY33=RAM(IQ+12) C Half matrix R BR11=-RAM(IQ+13) BR12=-RAM(IQ+14) BR22=-RAM(IQ+15) BR13=-RAM(IQ+16) BR23=-RAM(IQ+17) BR33=-RAM(IQ+18) C Determinant of the 2*2 submatrix of half Y DET=BY11*BY22-BY12*BY12 C Determinant of half matrix Y BYDET=BY33*DET-BY11*BY23*BY23 * +BY13*(2.0*BY12*BY23-BY22*BY13) C Amplitude coefficients AUX=2.0*SQRT(SQRT(8.0*BYDET)/COEF3D) BAMPR=AUX*RAM(IQ+19) BAMPI=AUX*RAM(IQ+20) C Matrix inverse to the 2*2 submatrix of Y times (BY13,BY23) AY13=( BY22*BY13-BY12*BY23)/DET AY23=(-BY12*BY13+BY11*BY23)/DET C Extent of the Gabor function along axis X3 AUX=SQRT(RELLOG*DET/BYDET) J3=MAX0(INT((BX3-AUX-O3)/D3+0.999),0) K3=MIN0(INT((BX3+AUX-O3)/D3+0.001),N3-1) DO 233 I3=J3,K3 DX3=O3+D3*FLOAT(I3)-BX3 C C Transforming 3-D Gabor packet to 2-D Gabor packet C Shift of the central point DX1=-AY13*DX3 DX2=-AY23*DX3 C Central point of the 2-D Gabor packet AX1=BX1+DX1 AX2=BX2+DX2 C Wavenumber vetor of the 2-D Gabor packet AK1=BK1+2.0*(BR11*DX1+BR12*DX2+BR13*DX3) AK2=BK2+2.0*(BR12*DX1+BR22*DX2+BR23*DX3) C Exponent of the 2-D Gabor packet at its central point AR33= DX1*(BK1+BR11*DX1+2.0*(BR12*DX2+BR13*DX3)) AR33=AR33+DX2*(BK2+BR22*DX2+2.0* BR23*DX3) AR33=AR33+DX3*(BK3+BR33*DX3) AY33=(BY33-BY13*AY13-BY23*AY23)*DX3*DX3 C Matrices BY11,BY12,BY22 and BR11,BR12,BR22 keep unchanged. C C Extent of the Gabor function along axis X2 AUX=RELLOG-AY33 IF(AUX.GE.0.0) THEN AUX=SQRT(AUX*BY11/DET) J2=MAX0(INT((AX2-AUX-O2)/D2+0.999),0) K2=MIN0(INT((AX2+AUX-O2)/D2+0.001),N2-1) DO 232 I2=J2,K2 DX2=O2+D2*FLOAT(I2)-AX2 C Extent of the Gabor function along axis X1 AUX=RELLOG-AY33-(DET/BY11)*DX2*DX2 IF(AUX.GE.0.0) THEN AUX=SQRT(AUX/BY11) DX1=AX1-BY12*DX2/BY11-O1 J1=MAX0(INT((DX1-AUX)/D1+0.999),0) K1=MIN0(INT((DX1+AUX)/D1+0.001),N1-1) IF(J1.LE.K1) THEN C Index of the central point along the gridline M1=MAX0(J1,MIN0(NINT(DX1/D1),K1)) C Relative coordinate of the central point DX1=O1+D1*FLOAT(M1)-AX1 C Exponent at the central point EXP0R=AY33 EXP0R=EXP0R+DX1*(BY11*DX1+2.0*BY12*DX2) EXP0R=EXP0R+DX2* BY22*DX2 EXP0I=AR33 EXP0I=EXP0I+DX1*(AK1+BR11*DX1+2.0*BR12*DX2) EXP0I=EXP0I+DX2*(AK2+BR22*DX2) C The first derivative of the exponent EXP1R=BY11*DX1+BY12*DX2 EXP1I=BR11*DX1+BR12*DX2 EXP1R=D1*(EXP1R+EXP1R) EXP1I=D1*(EXP1I+EXP1I+AK1) C Half the second derivative of the exponent EXP2R=D1*BY11*D1 EXP2I=D1*BR11*D1 C Half the second derivative minus first derivative EXP1MR=EXP2R-EXP1R EXP1MI=EXP2I-EXP1I C Half the second derivative plus first derivative EXP1R=EXP2R+EXP1R EXP1I=EXP2I+EXP1I C Second derivative of the exponent EXP2R=EXP2R+EXP2R EXP2I=EXP2I+EXP2I C Exponential function at the central point AUX=EXP(-EXP0R) C=COS(EXP0I) S=SIN(EXP0I) EXP0R=C*AUX EXP0I=S*AUX C Exponential correction at the central point (+) AUX=EXP(-EXP1R) C=COS(EXP1I) S=SIN(EXP1I) EXP1R=C*AUX EXP1I=S*AUX C Exponential correction at the central point (-) AUX=EXP(-EXP1MR) C=COS(EXP1MI) S=SIN(EXP1MI) EXP1MR=C*AUX EXP1MI=S*AUX C Constant correction to the correction AUX=EXP(-EXP2R) C=COS(EXP2I) S=SIN(EXP2I) EXP2R=C*AUX EXP2I=S*AUX C C Contribution to the integral at the central point I=NQNSGF+1+M1+N1*(I2+N2*I3) RAM(I)=RAM(I)+BAMPR*EXP0R-BAMPI*EXP0I C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Loop over the gridpoints DO 230 I1=I+1,I+K1-M1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX RAM(I1)=RAM(I1)+BAMPR*EXPR-BAMPI*EXPI 230 CONTINUE C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Exponential correction at the central point EXP1R=EXP1MR EXP1I=EXP1MI C Loop over the gridpoints DO 231 I1=I-1,I+J1-M1,-1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX RAM(I1)=RAM(I1)+BAMPR*EXPR-BAMPI*EXPI 231 CONTINUE END IF END IF 232 CONTINUE END IF 233 CONTINUE END IF 234 CONTINUE END IF C C Writing the output grid: FORM='FORMATTED' CALL WARRAY(LU1,FGRD,FORM,.FALSE.,0.0,.FALSE.,0.0, * N1N2N3,RAM(NQNSGF+1)) C WRITE(*,'(A)') '+SGFGRD: 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 'mat.for' C mat.for C C======================================================================= Csgfhom.for 0100666 0000765 0000765 00000063164 11023416420 012427 0 ustar bulant bulant C
C Program SGFHOM to generate the structural Gabor functions which shape C is optimized for a zero-offset surface seismic reflection survey C in a homogeneous 2-D velocity model C C Version: 6.20 C Date: 2008, June 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 Data specifying output files: C SGF='string'... Name of the output file with structural Gabor C functions. C Input for programs C sgfmat.for C and sgpini.for. C The file is not generated if SGF=' '. C Description of file SGF. C Default: SGF='sgf.out' C PTS='string'... Name of the output file with the central points of C structural Gabor functions. If several Gabor functions C have equal central point, this central point appears only C once in file PTS. C Input for program C mtt.for C which should calculate the the Green tensors corresponding C to the waves incident from the given sources to these C points. The Green tensors are then read by program C sgpini.for. C The file is not generated if PTS=' '. C Description of file PTS. C Default: PTS='pts.out' C SGFPTS='string'... Name of the output file linking the structural C Gabor functions of file SGF to central points of file PTS. C Input for program C sgpini.for. C The file is not generated if SGFPTS=' '. C Description of file SGFPTS. C Default: SGFPTS='sgfpts.out' C Data specifying the phase-space region covered by Gabor functions: C X1MIN=real, X1MAX=real, X2MIN=real, X2MAX=real, X3MIN=real, C X3MAX=real... Cartesian coordinates specifying the boundaries of C the rectangular spatial volume inside which the central C points of structural Gabor functions are located. C In the current 2-D version, this volume should be reduced C to a 2-D rectangle by specifying X1MIN=X1MAX or C X2MIN=X2MAX or X3MIN=X3MAX. For a 2-D rectangle, only 2-D C wavenumber vector is considered. C It is also possible to reduce this volume to a 1-D line C segment for testing purposes. For a 1-D line segment, C only 1-D wavenumber vector is considered. C Defaults: X1MIN=0.0, X1MAX=0.0, X2MIN=0.0, X2MAX=0.0, C X3MIN=0.0, X3MAX=0.0 C WKMIN=real... Minimum absolute value of the projection of the C structural wavenumber vector onto the normal to the C surface at which the seismic sources and receivers are C situated. WKMIN must be non-negative. C Default: WKMIN=0. C WKMAX=real... Maximum norm of the structural wavenumber vector. C No default: WKMAX must be specified and must be greater C than WKMIN. C Data specifying the phase-space density of Gabor functions: C REDUNDANCY=real... Redundancy ratio with respect to one spatial C direction and the corresponding wavenumber. C The redundancy ratio corresponds to 2*PI/(DX*DK), C where DX*DK is the product of the spatial and wavenumber C discretization steps. C The redundancy ratio should be greater than 1. C Default: REDUNDANCY=1.1 C LATTICEV=integer... Structure of the lattice of the central points C of Gabor functions in the coordinate plane WX3, WK3, where C coordinate WX3 and wavenumber component WK3 are measured C perpendicularly to the surface at which the seismic C sources and receivers are situated. C Parameter LATTICEV specifies the position of hyperbolae C WX3*WK3=constant containing the chains of central points C of Gabor functions. C LATTICEV=0: The hyperbolae are positioned with respect to C WX3MIN and WKMIN. Point (WX3,WK3)=(WX3MIN,WKMIN) is C situated in the middle between two hyperbolae. C There is a gap (-WKMIN,+WKMIN) between positive and C negative vertical wavenumbers WK3. C LATTICEV=1: The hyperbolae are independent of the given C phase-space domain. There is a rough continuation C between positive and negative vertical wavenumbers WK3, C except for the central points removed from interval C (-WKMIN,+WKMIN). If WKMIN=0 (or WX3MIN=0), options C LATTICEV=0 and LATTICEV=1 are equal. C LATTICEV=2: The hyperbolae are independent of the given C phase-space domain, and are located strictly according C to Klimes(2008), with at least one chain of points C missing between positive and negative vertical C wavenumbers WK3 even for WKMIN=0. C Default: LATTICEV=0 C LATTICEH=integer... Structure of the lattice of the central points C WX3=constant, WK3=constant of the phase space, where C coordinate WX3 and wavenumber component WK3 are measured C perpendicularly to the surface at which the seismic C sources and receivers are situated. C LATTICEH=0: Oblique lattice with very regular coverage C according to equations (77)-(80) in 2-D. C LATTICEH=1: Rectangular lattice according to equations C (72)-(74). C LATTICEH=2: Rectangular lattice according to equations C (72), (75) and (76). C Default: LATTICEH=0 C Data specifying the surface with seismic sources and receivers: C SRF1=real, SRF2=real, SRF3=real... Unit vector perpendicular to C the surface at which the seismic sources and receivers are C situated. If the specified vector is not unit, it is C normalized by this program. C The surface should not intersect the rectangular spatial C volume inside which the central points of structural Gabor C functions are located. C The vector should point from the surface towards the C rectangular spatial volume inside which the central points C of structural Gabor functions are located. C In the current 2-D version, the specified vector should C be parallel with the specified 2-D rectangle. C Defaults: SRF1=0.0, SRF2=0.0, SRF3=-1.0 C SRF0=real... Value of the scalar product of the coordinates C of the seismic sources and receivers with unit vector C (SRF1,SRF2,SRF3). C Default: SRF0=0.0 C Output format: C MAXDIG=positive integer... Minimum number of digits of a positive C number in the output format. C MAXDIG must be less than 10. C Default: MAXDIG=6 C MINDIG=positive integer... Number of digits to change editing F C to editing G. C MINDIG should be less than MAXDIG. C Default: MINDIG=4 C C C File SGF with structural Gabor functions: C (version of form PTS): C (1) None to several strings terminated by / (a slash) C (2) For each couple of Gabor functions data (2.1): C (2.1) 'IGF',X1,X2,X3,K1,K2,K3,RK11,RK12,RK22,RK13,RK23,RK33, C YK11,YK12,YK22,YK13,YK23,YK33,/ C 'IGF'... Name of the data line. The names are odd C integers. C X1,X2,X3... Coordinates of the central point of the C structural Gabor function. C K1,K2,K3... Real-valued structural wavenumber. C RK11,RK12,RK22,RK13,RK23,RK33... Real part of the symmetric 3*3 C matrix K describing the envelope of the structural Gabor C function. C YK11,YK12,YK22,YK13,YK23,YK33... Imaginary part of the symmetric C 3*3 matrix K describing the envelope of the structural Gabor C function. C One data line describes two Gabor functions: C Gabor function IGF with wavenumber (K1,K2,K3), matrix K, C and unknown complex-valued model coefficients; C Gabor function IGF+1 with wavenumber (-K1,-K2,-K3), C complex-conjugate matrix K, and complex-conjugate model C coefficients. C (3) / or end of file. C C C File PTS with central points of the structural Gabor functions C for calculating quantities corresponding to the incident wave C by program mtt.for C (version of form PTS): C (1) None to several strings terminated by / (a slash) C (2) For each point data (2.1): C (2.1) 'IPT',X1,X2,X3,/ C 'IPT'... Name of the point corresponding to the smallest index IGF C of Gabor functions centred at the point. C X1,X2,X3... Coordinates of the central point common to several C structural Gabor functions. C (3) / or end of file. C C C File SGFPTS linking the structural Gabor functions of file SGF to the C central points of file PTS: C (1) None to several strings terminated by / (a slash) C (2) For each Gabor function of file SGF data (2.1): C (2.1) 'IGF','IPT',/ C 'IGF'.. Name of the structural Gabor function of file SGF. C The names are odd integers. C 'IPT'.. Name of the central point of file PTS. C The name corresponds to the smallest index of Gabor C functions centred at the point. C (3) / or end of file. C C======================================================================= C C External functions and subroutines: EXTERNAL RSEP1,RSEP3T,RSEP3R,ERROR,FORM2 C C Filenames and parameters: CHARACTER*80 FSEP,FSGF,FPTS,FSGFPT INTEGER LU1,LU2,LU3 PARAMETER (LU1=1,LU2=2,LU3=3) C C Input data: INTEGER LATICV,LATICH REAL X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX,WKMIN,WKMAX REAL REDUND,SRF0,SRF1,SRF2,SRF3 C C Output data: INTEGER NOUT,IGF,IGFMAX,IPT PARAMETER (NOUT=18) REAL X1,X2,X3,OUT(NOUT) CHARACTER*(11+8*NOUT) FORMAT C C Transformation matrix: C REAL E10,E20,E30,E11,E21,E31,E12,E22,E32,E13,E23,E33 REAL E10,E20,E30,E11,E21,E31,E13,E23,E33 REAL E1111,E1211,E2211,E1311,E2311,E3311 C REAL E1113,E1213,E2213,E1313,E2313,E3313 REAL E1133,E1233,E2233,E1333,E2333,E3333 C C Constants describing the Gabor functions: REAL PI,STEP0,Y0,R0,ALPHA,DW4 PARAMETER (PI=3.141592654) C C Gabor functions in working coordinates: REAL WX1,WX3,WK1,WK3,Y11,Y33,R11,R33 REAL WX1MIN,WX1MAX,WX1INI,WX3MIN,WX3MAX,DWX1,DWK1,DWK1I2,WK1INI C C Other variables: INTEGER I1MIN,I1MAX,I2MIN,I2MAX,I3MIN,I3MAX,I4MIN,I4MAX INTEGER I1,I2,I3,I4,I REAL W4INI,W4,AUX C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+SGFHOM: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C SGFHOM-01 CALL ERROR('SGFHOM-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)') '+SGFHOM: Working... ' C C Reading output filenames: CALL RSEP3T('SGF' ,FSGF ,'sgf.out') CALL RSEP3T('PTS' ,FPTS ,'pts.out' ) CALL RSEP3T('SGFPTS',FSGFPT,'sgfpts.out') C C Reading other input SEP parameters: CALL RSEP3R('X1MIN' ,X1MIN ,0.0) CALL RSEP3R('X1MAX' ,X1MAX ,0.0) CALL RSEP3R('X2MIN' ,X2MIN ,0.0) CALL RSEP3R('X2MAX' ,X2MAX ,0.0) CALL RSEP3R('X3MIN' ,X3MIN ,0.0) CALL RSEP3R('X3MAX' ,X3MAX ,0.0) CALL RSEP3R('WKMIN' ,WKMIN ,0.0) CALL RSEP3R('WKMAX' ,WKMAX ,0.0) CALL RSEP3R('REDUNDANCY',REDUND,1.1) CALL RSEP3I('LATTICEV',LATICV,0) CALL RSEP3I('LATTICEH',LATICH,0) CALL RSEP3R('SRF0' ,SRF0 ,0.0) CALL RSEP3R('SRF1' ,SRF1 ,0.0) CALL RSEP3R('SRF2' ,SRF2 ,0.0) CALL RSEP3R('SRF3' ,SRF3 ,-1.0) IF(X1MIN.GT.X1MAX.OR.X2MIN.GT.X2MAX.OR.X3MIN.GT.X3MAX) THEN C SGFHOM-02 CALL ERROR('SGFHOM-02: Wrong boundaries of the spatial volume') C Minimum coordinate bounding the spatial volume is greater than C the corresponding maximum coordinate. END IF IF(WKMIN.LT.0.0.OR.WKMIN.GE.WKMAX) THEN C SGFHOM-03 CALL ERROR('SGFHOM-03: Wrong boundaries of the wavenumbers') C The minimum wavenumber must be non-negative and smaller than the C maximum wavenumber. END IF IF(X1MIN.LT.X1MAX.AND.X2MIN.LT.X2MAX.AND.X3MIN.LT.X3MAX) THEN C SGFHOM-04 CALL ERROR('SGFHOM-04: 3-D spatial volume') C In the current 2-D version, the spatial volume specified by C X1MIN, X1MAX, X2MIN, X2MAX, X3MIN, X3MAX must be 2-D. END IF C C Opening the output files and writing their beginnings: IF(FSGF.NE.' ') THEN OPEN (LU1,FILE=FSGF,FORM='FORMATTED') WRITE(LU1,'(A)') '/' END IF IF(FPTS.NE.' ') THEN OPEN (LU2,FILE=FPTS,FORM='FORMATTED') WRITE(LU2,'(A)') '/' END IF IF(FSGFPT.NE.' ') THEN OPEN (LU3,FILE=FSGFPT,FORM='FORMATTED') WRITE(LU3,'(A)') '/' END IF C C Transformation matrix from working to output coordinates: AUX=SQRT(SRF1*SRF1+SRF2*SRF2+SRF3*SRF3) IF(AUX.LE.0.0) THEN C SGFHOM-05 CALL ERROR('SGFHOM-05: Zero vector (SRF1,SRF2,SRF3)') END IF C E12=0.0 C E22=0.0 C E32=0.0 E13=SRF1/AUX E23=SRF2/AUX E33=SRF3/AUX E10=E13*SRF0 E20=E23*SRF0 E30=E33*SRF0 IF(X1MIN.EQ.X1MAX) THEN IF(SRF1.NE.0.0) THEN C SGFHOM-06 CALL ERROR('SGFHOM-06: Non-zero SRF1') C In the current 2-D version, specified vector (SRF1,SRF2,SRF3) C must be parallel with the 2-D rectangle specified by C X1MIN, X1MAX, X2MIN, X2MAX, X3MIN, X3MAX. END IF E11= 0.0 E21=-E33 E31= E23 C Disabling the check of position affected by rounding errors X1MIN=X1MIN-ABS(X1MIN) X1MAX=X1MAX-ABS(X1MAX) END IF IF(X2MIN.EQ.X2MAX) THEN IF(SRF2.NE.0.0) THEN C SGFHOM-07 CALL ERROR('SGFHOM-07: Non-zero SRF1') C In the current 2-D version, specified vector (SRF1,SRF2,SRF3) C must be parallel with the 2-D rectangle specified by C X1MIN, X1MAX, X2MIN, X2MAX, X3MIN, X3MAX. END IF E11=-E33 E21= 0.0 E31= E13 C Disabling the check of position affected by rounding errors X2MIN=X2MIN-ABS(X2MIN) X2MAX=X2MAX-ABS(X2MAX) END IF IF(X3MIN.EQ.X3MAX) THEN IF(SRF3.NE.0.0) THEN C SGFHOM-08 CALL ERROR('SGFHOM-08: Non-zero SRF1') C In the current 2-D version, specified vector (SRF1,SRF2,SRF3) C must be parallel with the 2-D rectangle specified by C X1MIN, X1MAX, X2MIN, X2MAX, X3MIN, X3MAX. END IF E11=-E23 E21= E13 E31= 0.0 IF(X1MIN.EQ.X1MAX.OR.X2MIN.EQ.X2MAX) THEN E11=0.0 E21=0.0 END IF C Disabling the check of position affected by rounding errors X3MIN=X3MIN-ABS(X3MIN) X3MAX=X3MAX-ABS(X3MAX) END IF WX1MIN=AMIN1(E11*X1MIN,E11*X1MAX) * +AMIN1(E21*X2MIN,E21*X2MAX) * +AMIN1(E31*X3MIN,E31*X3MAX) WX1MAX=AMAX1(E11*X1MIN,E11*X1MAX) * +AMAX1(E21*X2MIN,E21*X2MAX) * +AMAX1(E31*X3MIN,E31*X3MAX) WX3MIN=AMIN1(E13*X1MIN,E13*X1MAX) * +AMIN1(E23*X2MIN,E23*X2MAX) * +AMIN1(E33*X3MIN,E33*X3MAX) WX3MAX=AMAX1(E13*X1MIN,E13*X1MAX) * +AMAX1(E23*X2MIN,E23*X2MAX) * +AMAX1(E33*X3MIN,E33*X3MAX) WX1INI=0.5*(WX1MIN+WX1MAX) IF(WX3MIN.LT.0.0) THEN IF(WX3MAX.LE.0.0) THEN C SGFHOM-09 CALL ERROR('SGFHOM-09: Wrong vector (SRF1,SRF2,SRF3)') C Vector (SRF1,SRF2,SRF3) is not oriented towards the spatial C volume specified by X1MIN, X1MAX, X2MIN, X2MAX, X3MIN, X3MAX. ELSE C SGFHOM-10 CALL ERROR('SGFHOM-10: Wrong position of the surface') C The surface with seismic sources and receivers intersects C the spatial volume specified by X1MIN, X1MAX, X2MIN, X2MAX, C X3MIN, X3MAX. END IF END IF E1111=E11*E11 E1211=E11*E21 E2211=E21*E21 E1311=E11*E31 E2311=E21*E31 E3311=E31*E31 C E1113=E11*E13*2.0 C E1213=E11*E23+E13*E21 C E2213=E21*E23*2.0 C E1313=E11*E33+E13*E21 C E2313=E21*E33+E13*E21 C E3313=E31*E33*2.0 E1133=E13*E13 E1233=E13*E23 E2233=E23*E23 E1333=E13*E33 E2333=E23*E33 E3333=E33*E33 C C Initial values for output: IGF=1 FORMAT(1:11)='(A,I6.6,2A,' C Maximum integer fitting into the above format IGFMAX=999999 C C Constants describing the Gabor functions: STEP0=SQRT(2.0*PI/REDUND) Y0=SQRT(3.0)/4.0 R0=5.0/4.0 AUX=(1.0+R0)**2/Y0+Y0 ALPHA=2.0/AUX DW4=0.5*STEP0*SQRT(AUX) C C Positioning hyperbolae containing the chains of lattice points IF(LATICV.EQ.0) THEN C Hyperbolae positioned with respect to WX3MIN and WKMIN W4INI=SQRT(WX3MIN*WKMIN)+0.5*DW4 ELSE IF(LATICV.EQ.1) THEN C Hyperbolae independent of the phase-space domain W4INI=0.5*DW4 ELSE IF(LATICV.EQ.2) THEN C Hyperbolae according to Klimes(2008) W4INI=0.0 ELSE C SGFHOM-11 CALL ERROR('SGFHOM-11: Wrong SEP parameter LATTICEV') C Refer to the input data. END IF C C Loops over Gabor functions: I4MIN=NINT((SQRT(WX3MIN*WKMIN)-W4INI)/DW4+0.499) I4MAX=NINT((SQRT(WX3MAX*WKMAX)-W4INI)/DW4-0.499) DO 14 I4=I4MIN,I4MAX W4=W4INI+DW4*FLOAT(I4) I3MIN=NINT(ALOG(W4/WKMAX)*W4/DW4/ALPHA+0.499) IF(WX3MIN.GT.0.0) THEN I3MIN=MAX0(NINT(ALOG(WX3MIN/W4)*W4/DW4/ALPHA+0.499),I3MIN) END IF I3MAX=NINT(ALOG(WX3MAX/W4)*W4/DW4/ALPHA-0.499) IF(WKMIN.GT.0.0) THEN I3MAX=MIN0(NINT(ALOG(W4/WKMIN)*W4/DW4/ALPHA-0.499),I3MAX) END IF DO 13 I3=I3MIN,I3MAX WX3=W4*EXP(ALPHA*FLOAT(I3)*DW4/W4) WK3=W4*W4/WX3 Y33=Y0*WK3/WX3 R33=R0*WK3/WX3 Y11=Y33 R11=R33 IF(LATICH.EQ.0) THEN C Basic option according to equations (77)-(80) in 2-D AUX=SQRT(Y11*2.0/SQRT(3.0)) DWX1=STEP0/AUX DWK1=STEP0*AUX DWK1I2=0.5*DWK1+R11*DWX1 ELSE IF(LATICH.EQ.1) THEN C First option according to equations (72)-(74) AUX=SQRT(Y11) DWX1=STEP0/AUX DWK1=STEP0*AUX DWK1I2=0.0 ELSE IF(LATICH.EQ.2) THEN C Second option according to equations (72), (75) and (76) AUX=SQRT(R11**2/Y11+Y11) DWX1=STEP0/AUX DWK1=STEP0*AUX DWK1I2=0.0 ELSE C SGFHOM-12 CALL ERROR('SGFHOM-12: Wrong SEP parameter LATTICEH') C Refer to the input data. END IF C C Loop over the horizontal coordinate: I2MAX=INT((WX1MAX-WX1INI)/DWX1) I2MIN=-I2MAX DO 12 I2=I2MIN,I2MAX WX1=WX1INI+DWX1*FLOAT(I2) WK1INI=DWK1I2*FLOAT(I2) C C Transformation to output coordinates: C Coordinates of the Gabor function X1=E10+E11*WX1+E13*WX3 X2=E20+E21*WX1+E23*WX3 X3=E30+E31*WX1+E33*WX3 C Checking the phase-space position of the Gabor function IF(X1MIN.LE.X1.AND.X1.LE.X1MAX.AND. * X2MIN.LE.X2.AND.X2.LE.X2MAX.AND. * X3MIN.LE.X3.AND.X3.LE.X3MAX.AND. * WKMIN.LE.WK3.AND.WK3.LE.WKMAX) THEN C Writing the central coordinates of the Gabor functions OUT(1)=X1 OUT(2)=X2 OUT(3)=X3 IF(FPTS.NE.' ') THEN IF(IGF.GE.IGFMAX) THEN C C SGFHOM-13 CALL ERROR('SGFHOM-13: Too many Gabor functions') C The number of Gabor functions exceeds the maximum C number which fits into the string describing each C Gabor function, see IGFMAX. END IF IPT=IGF CALL FORM2(3,OUT,OUT,FORMAT(12:11+8*3)) WRITE(LU2,FORMAT) '''',IPT,'''',(' ',OUT(I),I=1,3),' /' END IF C C Loop over the horizontal component of wavenumber vector: I1MAX=NINT(( SQRT(WKMAX*WKMAX-WK3*WK3)-WK1INI)/DWK1-0.5) I1MIN=NINT((-SQRT(WKMAX*WKMAX-WK3*WK3)-WK1INI)/DWK1+0.5) IF(WX1MIN.EQ.WX1MAX) THEN I1MIN=0 I1MAX=0 WK1INI=0.0 END IF DO 11 I1=I1MIN,I1MAX WK1=WK1INI+DWK1*FLOAT(I1) C C Transformation to output coordinates: IF(FSGF.NE.' ') THEN C Wavenumber vector with opposite sign OUT( 4)=-E11*WK1-E13*WK3 OUT( 5)=-E21*WK1-E23*WK3 OUT( 6)=-E31*WK1-E33*WK3 C Real part of matrix K OUT( 7)=E1111*Y11+E1133*Y33 OUT( 8)=E1211*Y11+E1233*Y33 OUT( 9)=E2211*Y11+E2233*Y33 OUT(10)=E1311*Y11+E1333*Y33 OUT(11)=E2311*Y11+E2333*Y33 OUT(12)=E3311*Y11+E3333*Y33 C Imaginary part of matrix K with opposite sign OUT(13)=E1111*R11+E1133*R33 OUT(14)=E1211*R11+E1233*R33 OUT(15)=E2211*R11+E2233*R33 OUT(16)=E1311*R11+E1333*R33 OUT(17)=E2311*R11+E2333*R33 OUT(18)=E3311*R11+E3333*R33 C Writing IF(IGF.GE.IGFMAX) THEN C C SGFHOM-14 CALL ERROR('SGFHOM-14: Too many Gabor functions') C The number of Gabor functions exceeds the maximum C number which fits into the string describing each C Gabor function, see IGFMAX. END IF CALL FORM2(NOUT,OUT,OUT,FORMAT(12:11+8*NOUT)) WRITE(LU1,FORMAT) * '''',IGF,'''',(' ',OUT(I),I=1,NOUT),' /' END IF IF(FSGFPT.NE.' ') THEN WRITE(LU3,'(3(A,I6.6))') '''',IGF,''' ''',IPT,''' /' END IF IGF=IGF+2 11 CONTINUE END IF 12 CONTINUE 13 CONTINUE 14 CONTINUE C C Closing the output files: IF(FSGF.NE.' ') THEN WRITE(LU1,'(A)') '/' CLOSE(LU1) END IF IF(FPTS.NE.' ') THEN WRITE(LU2,'(A)') '/' CLOSE(LU2) END IF IF(FSGFPT.NE.' ') THEN WRITE(LU3,'(A)') '/' CLOSE(LU3) END IF WRITE(*,'(A,I9,A)') '+SGFHOM: Done.',IGF-1,' Gabor functions' 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======================================================================= Csgfmat.for 0100666 0000765 0000765 00000204576 11024140020 012420 0 ustar bulant bulant C
C Program SGFMAT to generate the system of linear equations for C the complex-valued coefficients of the structural Gabor functions C in decomposing a given gridded real-valued quantity C C Version: 6.20 C Date: 2008, June 12 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 Two unknown real-valued coefficients stand in for the complex-valued C coefficient of each odd Gabor function. The odd unknown real-valued C coefficient is the real part, and the even unknown real-valued C coefficient is the imaginary part. These two real-valued coefficients C simultaneously represent the complex-valued coefficient of the C successive even Gabor function because the two Gabor functions and C the corresponding complex-valued coefficients are complex-conjugate. C Each odd unknown real-valued coefficient thus corresponds to twice the C real part of the Gabor function of the same odd index, and each even C unknown real-valued coefficient corresponds to twice the imaginary C part of the Gabor function of the same even index. C C Program SGFMAT generates the sparse symmetric real-valued matrix of C the scalar products between the above mentioned real-valued functions C corresponding to individual unknown real-valued coefficients, C and the real-valued vector of the scalar products of these real-valued C functions with the given gridded real-valued quantity. 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 and output files: C SGF='string'... Name of the input file with structural Gabor C functions. Input parameters N1, N2, N3 determine whether C the structural Gabor functions are 1-D, 2-D or 3-D. C The wavemumber components and matrix elements C corresponding to the direction in which the number of C gridpoints is Ni=1 should equal zero. C Description of file SGF. C Default: SGF='sgf.out' C GRD='string'... Name of the formatted input file with a gridded C real-valued quantity. The file contains N1*N2*N3 values. C The file is not read if SGFRHS=' '. C For general description of files with gridded data refer C to file forms.htm. C No default: If SGFRHS is not blank, GRD must be specified C and cannot be blank. C SGFMAT='string'... Name of the header file of the output sparse C symmetric square real-valued matrix of the scalar products C between the real-valued functions corresponding to C individual unknown real-valued coefficients. This matrix C represents the coefficients of the linear equations for C the unknown complex-valued coefficients. C If SGFMAT is blank, the file is not created. C For general description of the files with matrices refer C to file forms.htm. C Default: SGFMAT='sgfmat.out' C SGFRHS='string'... Name of the header file of the output C real-valued vector of the scalar products of the given C gridded real-valued quantity with the real-valued C functions corresponding to individual unknown real-valued C coefficients. This vector represents the right-hand sides C of the linear equations for the unknown complex-valued C coefficients. C If SGFRHS is blank, the file is not created. C For general description of the files with matrices refer C to file forms.htm. C Default: SGFRHS='sgfrhs.out' C Data specifying dimensions of the input grid: C N1,N2,N3=integers... Numbers of gridpoints along the X1,X2,X3 C axes, respectively. These numbers also determine whether C the structural Gabor functions are 1-D, 2-D or 3-D. C Defaults: N1=1, N2=1, N3=1 C O1,O2,O3=reals... Coordinates of the origin of the grid, i.e., C of the first gridpoint. C Defaults: O1=0, O2=0, O3=0 C D1,D2,D3=reals... Grid intervals along the X1,X2,X3 axes, C respectively. C Defaults: D1=1, D2=1, D3=1 C Numerical parameters: C NULL=positive real... Scalar product smaller than NULL times the C product of the norms of multiplied functions is deemed to C be zero. C Default: 0.000001 C RELAMP=positive real... Relative decay of the Gaussian envelope C at which the loop over the points of the input grid is C terminated. C The relative error due to this economizing roughly C corresponds to the value of RELAMP. C Default: RELAMP=0.001 C Form of the output files with matrices: C FORMM='string' ... Form of the output files with matrices. Allowed C values are FORMM='formatted' and FORMM='unformatted'. C Default: FORMM='formatted' C Optional parameters specifying the form of the quantities C written to the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. C NUMLINM=positive integer ... Number of reals or integers in one C line of the output file. See the description in file C mat.for. C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of working array: INTEGER IRAM(MRAM),NRAM EQUIVALENCE (IRAM,RAM) C C....................................................................... C C External functions and subroutines: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3I,RSEP3R,RARRAY,WMATH,WMATD EXTERNAL STORE C C Constants: REAL COEF1D,COEF2D,COEF3D PARAMETER (COEF1D=1.772453851) PARAMETER (COEF2D=3.141592654) PARAMETER (COEF3D=5.568327997) C C Filenames and parameters: CHARACTER*80 FSEP,FSGF,FGRD,FMAT,FRHS,FDAT INTEGER LU1 PARAMETER (LU1=1) C C Input data: INTEGER N1,N2,N3,N1N2N3,NQ,NZ,NSGF,NQNSGF,NDIM REAL O1,O2,O3,D1,D2,D3,ANULL,ANULOG,RELAMP,RELLOG,ZERO(12) CHARACTER*1 TEXT C C Output data: INTEGER IMAT,NELEM0,NELEM CHARACTER*3 SPARSE CHARACTER*4 SYMM CHARACTER*11 FORM C C Gabor function b (beta): REAL BX1,BX2,BX3,BK1,BK2,BK3 REAL BY11,BY12,BY22,BY13,BY23,BY33,BYDET REAL BR11,BR12,BR22,BR13,BR23,BR33 REAL BXX1,BXX2,BXX3,BKK1,BKK2,BKK3 C Gabor function a (alpha), or 2-D projection of 3-D Gabor function: REAL AX1,AX2,AK1,AK2,AK3 REAL AY11,AY12,AY22,AY13,AY23,AY33,AYDET REAL AR11,AR12,AR22,AR13,AR23,AR33 C Differences and sums (Delta x, Delta k, matrices Y and R): REAL DX1,DX2,DX3,DK1,DK2,DK3 REAL YR11,YR21,YR31,YR12,YR22,YR32,YR13,YR23,YR33 REAL YI11,YI12,YI22,YI13,YI23,YI33 REAL RR11,RR12,RR22,RR13,RR23,RR33 REAL RI11,RI12,RI22,RI13,RI23,RI33 REAL ABKK1,ABKK2,ABKK3 C Determinant of matrix Y: REAL YDETR,YDETI,YDET2 C Inverse matrix to Y multiplied by the determinant of Y: REAL ZR11,ZR12,ZR22,ZR13,ZR23,ZR33 REAL ZI11,ZI12,ZI22,ZI13,ZI23,ZI33 C Products of matrices and vectors: REAL RDXR1,RDXR2,RDXR3,RDXI1,RDXI2,RDXI3 REAL ZRDXR1,ZRDXR2,ZRDXR3,ZRDXI1,ZRDXI2,ZRDXI3 REAL DXZDXR,DXZDXI C Square root of the determinant of matrix Y: REAL YDSQR,YDSQI,YDSQ2 C Calculation of scalar product (ga,gb): REAL EXPR,EXPI,C,S,GAGBR(2),GAGBI(2),VALUE,VALMIN C Calculation of scalar product with the given grid: REAL EXP0R,EXP0I,EXP1R,EXP1I,EXP1MR,EXP1MI,EXP2R,EXP2I REAL SUMR,SUMI INTEGER J1,J2,J3,K1,K2,K3,M1 C C Auxiliary variables: INTEGER ISGF1,ISGF2,IQ1,IQ2 INTEGER I1,I2,I3,I REAL DET,AUX C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+SGFMAT: Enter input filename: ' FSEP=' ' READ (*,*) FSEP IF(FSEP.EQ.' ') THEN C SGFMAT-01 CALL ERROR('SGFMAT-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)') '+SGFMAT: Working... ' C C Reading input and output filenames: CALL RSEP3T('SGF' ,FSGF,'sgf.out') CALL RSEP3T('GRD' ,FGRD,' ') CALL RSEP3T('SGFMAT',FMAT,'sgfmat.out') CALL RSEP3T('SGFRHS',FRHS,'sgfrhs.out') IF(FSGF.EQ.' ') THEN C SGFMAT-02 CALL ERROR('SGFMAT-02: Blank name of input file SGF') END IF IF(FGRD.EQ.' '.AND.FRHS.NE.' ') THEN C SGFMAT-03 CALL ERROR('SGFMAT-03: Name of input file GRD not specified') C If fileneme SGFRHS is not blank, the name of file GRD must be C specified and cannot be blank. END IF C C Reading other input SEP parameters: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3R('O1',O1,0.0) CALL RSEP3R('O2',O2,0.0) CALL RSEP3R('O3',O3,0.0) CALL RSEP3R('D1',D1,1.0) CALL RSEP3R('D2',D2,1.0) CALL RSEP3R('D3',D3,1.0) N1N2N3=N1*N2*N3 CALL RSEP3R('NULL',ANULL,0.000001) ANULOG=-ALOG(ANULL) CALL RSEP3R('RELAMP',RELAMP,0.001) RELLOG=-ALOG(RELAMP) C C Determination of NDIM: C 1-D: NDIM=1,2,3 C 2-D: NDIM=4,5,6 C 3-D: NDIM=7 NDIM=-1 IF(N1.GT.1) NDIM=NDIM+2 IF(N2.GT.1) NDIM=NDIM+3 IF(N3.GT.1) NDIM=NDIM+4 IF(NDIM.EQ.-1) THEN C SGFMAT-04 CALL ERROR('SGFMAT-04: N1=N2=N3=1 is not allowed') END IF IF(NDIM.EQ.2) THEN N1=N2 N2=1 O1=O2 D1=D2 ELSE IF(NDIM.EQ.3) THEN N1=N3 N3=1 O1=O3 D1=D3 ELSE IF(NDIM.EQ.5) THEN N2=N3 N3=1 O2=O3 D2=D3 ELSE IF(NDIM.EQ.6) THEN N1=N2 N2=N3 N3=1 O1=O2 O2=O3 D1=D2 D2=D3 ELSE IF(NDIM.EQ.8) THEN NDIM=7 END IF C C Determination of NQ and NZ: C NQ is the number of reals stored for each Gabor function C NZ is the number of input zeros for each Gabor function IF(NDIM.LE.3) THEN C 1-D NQ=6 NZ=12 ELSE IF(NDIM.LE.6) THEN C 2-D NQ=14 NZ=7 ELSE C 3-D: NQ=24 NZ=0 END IF C C Reading the Gabor functions: OPEN(LU1,FILE=FSGF,FORM='FORMATTED',STATUS='OLD') READ(LU1,*) (TEXT,I=1,20) NQNSGF=0 10 CONTINUE IF(NQNSGF+NQ.GT.MRAM) THEN C SGFMAT-05 CALL ERROR * ('SGFMAT-05: Too small array RAM for Gabor functions') C The input parameters of Gabor functions do not fit into array C RAM(MRAM). C The number of parameters of each Gabor function is C 1-D: NQ=6 C 2-D: NQ=14 C 3-D: NQ=24 END IF TEXT='$' GO TO (11,12,13,14,15,16,17) NDIM C SGFMAT-06 CALL ERROR('SGFMAT-06: Wrong value of NDIM') 11 CONTINUE READ(LU1,*,END=20) TEXT,RAM(NQNSGF+1),AUX,AUX, * RAM(NQNSGF+2),ZERO(1),ZERO(2), * RAM(NQNSGF+3),(ZERO(I),I=3,7), * RAM(NQNSGF+4),(ZERO(I),I=8,12) GO TO 18 12 CONTINUE READ(LU1,*,END=20) TEXT,AUX,RAM(NQNSGF+1),AUX, * ZERO(1),RAM(NQNSGF+2),(ZERO(I),I=2,4), * RAM(NQNSGF+3),(ZERO(I),I=5,9), * RAM(NQNSGF+4),(ZERO(I),I=10,12) GO TO 18 13 CONTINUE READ(LU1,*,END=20) TEXT,AUX,AUX,RAM(NQNSGF+1), * ZERO(1),ZERO(2),RAM(NQNSGF+2),(ZERO(I),I=3,7), * RAM(NQNSGF+3),(ZERO(I),I=8,12), * RAM(NQNSGF+4) GO TO 18 14 CONTINUE READ(LU1,*,END=20) TEXT,RAM(NQNSGF+1),RAM(NQNSGF+2),AUX, * RAM(NQNSGF+3),RAM(NQNSGF+4),ZERO(1), * RAM(NQNSGF+5),RAM(NQNSGF+6),RAM(NQNSGF+7), * (ZERO(I),I=2,4), * RAM(NQNSGF+8),RAM(NQNSGF+9),RAM(NQNSGF+10), * (ZERO(I),I=5,7) GO TO 18 15 CONTINUE READ(LU1,*,END=20) TEXT,RAM(NQNSGF+1),AUX,RAM(NQNSGF+2), * RAM(NQNSGF+3),ZERO(1),RAM(NQNSGF+4), * RAM(NQNSGF+5),ZERO(2),ZERO(3), * RAM(NQNSGF+6),ZERO(4),RAM(NQNSGF+7), * RAM(NQNSGF+8),ZERO(5),ZERO(6), * RAM(NQNSGF+9),ZERO(7),RAM(NQNSGF+10) GO TO 18 16 CONTINUE READ(LU1,*,END=20) TEXT,AUX,RAM(NQNSGF+1),RAM(NQNSGF+2), * ZERO(1),RAM(NQNSGF+3),RAM(NQNSGF+4), * ZERO(2),ZERO(3),RAM(NQNSGF+5), * ZERO(4),RAM(NQNSGF+6),RAM(NQNSGF+7), * ZERO(5),ZERO(6),RAM(NQNSGF+8), * ZERO(7),RAM(NQNSGF+9),RAM(NQNSGF+10) GO TO 18 17 CONTINUE READ(LU1,*,END=20) TEXT,(RAM(I),I=NQNSGF+1,NQNSGF+18) GO TO 18 18 CONTINUE IF(TEXT.EQ.'$') GO TO 20 NQNSGF=NQNSGF+NQ DO 19 I=1,NZ IF(ZERO(I).NE.0.0) THEN C SGFMAT-07 CALL ERROR ('SGFMAT-07: Non-zero input quantity') C The input wavemumber components and matrix elements C corresponding to the direction in which the number of C gridpoints is Ni=1 should equal zero. END IF 19 CONTINUE GO TO 10 20 CONTINUE CLOSE(LU1) NSGF=NQNSGF/NQ C NSGF is the number of odd Gabor functions. C RAM(1:NQNSGF) contain the parameters of odd Gabor functions. C C Checking the positive definiteness of the real part of matrix K, C calculating the squares of maximum differences between coordinates C and wavenumber components, and halving the components of matrix K: IF(NDIM.LE.3) THEN C 1-D: DO 32 I=0,NQNSGF-NQ,NQ IF(RAM(I+3).LE.0.0) THEN C SGFMAT-08 CALL ERROR('SGFMAT-08: Indefinite real part of matrix K') END IF C Squares of maximum phase-space coordinate differences RAM(I+5)=2.*ANULOG/RAM(I+3) RAM(I+6)=2.*ANULOG*(RAM(I+3)+RAM(I+4)**2/RAM(I+3)) C Halving the components of matrix K DO 31 I1=I+3,I+4 RAM(I1)=0.5*RAM(I1) 31 CONTINUE 32 CONTINUE ELSE IF(NDIM.LE.6) THEN C 2-D: DO 42 I=0,NQNSGF-NQ,NQ DET=RAM(I+5)*RAM(I+7)-RAM(I+6)**2 IF(RAM(I+5).LE.0.0.OR.DET.LE.0.0) THEN C SGFMAT-09 CALL ERROR('SGFMAT-09: Indefinite real part of matrix K') END IF C Squares of maximum phase-space coordinate differences RAM(I+11)=2.*ANULOG*RAM(I+7)/DET RAM(I+12)=2.*ANULOG*RAM(I+5)/DET AUX=RAM(I+8)*RAM(I+7)*RAM(I+8)+RAM(I+9)*RAM(I+5)*RAM(I+9) * -2.0*RAM(I+8)*RAM(I+6)*RAM(I+9) RAM(I+13)=2.*ANULOG*(RAM(I+5)+AUX/DET) AUX=RAM(I+9)*RAM(I+7)*RAM(I+9)+RAM(I+10)*RAM(I+5)*RAM(I+10) * -2.0*RAM(I+9)*RAM(I+6)*RAM(I+10) RAM(I+14)=2.*ANULOG*(RAM(I+7)+AUX/DET) C Halving the components of matrix K DO 41 I1=I+5,I+10 RAM(I1)=0.5*RAM(I1) 41 CONTINUE 42 CONTINUE ELSE C 3-D: DO 52 I=0,NQNSGF-NQ,NQ C Matrix Y BY11=RAM(I+7) BY12=RAM(I+8) BY22=RAM(I+9) BY13=RAM(I+10) BY23=RAM(I+11) BY33=RAM(I+12) C Matrix R BR11=-RAM(I+13) BR12=-RAM(I+14) BR22=-RAM(I+15) BR13=-RAM(I+16) BR23=-RAM(I+17) BR33=-RAM(I+18) C Inverse matrix to Y multiplied by det(Y) AY11=BY22*BY33-BY23*BY23 AY12=BY13*BY23-BY12*BY33 AY22=BY11*BY33-BY13*BY13 AY13=BY12*BY23-BY13*BY22 AY23=BY12*BY13-BY23*BY11 AY33=BY11*BY22-BY12*BY12 C det(Y) BYDET=BY11*AY11+BY12*AY12+BY13*AY13 IF(BY11.LE.0.0.OR.AY33.LE.0.0.OR.BYDET.LE.0.0) THEN C SGFMAT-10 CALL ERROR('SGFMAT-10: Indefinite real part of matrix K') END IF C Products of matrices YR11=AY11*BR11+AY12*BR12+AY13*BR13 YR21=AY12*BR11+AY22*BR12+AY23*BR13 YR31=AY13*BR11+AY23*BR12+AY33*BR13 YR12=AY11*BR12+AY12*BR22+AY13*BR23 YR22=AY12*BR12+AY22*BR22+AY23*BR23 YR32=AY13*BR12+AY23*BR22+AY33*BR23 YR13=AY11*BR12+AY12*BR22+AY13*BR23 YR23=AY12*BR13+AY22*BR23+AY23*BR33 YR33=AY13*BR13+AY23*BR23+AY33*BR33 AR11=BR11*YR11+BR12*YR21+BR13*YR31 AR22=BR12*YR12+BR22*YR22+BR23*YR32 AR33=BR13*YR13+BR23*YR23+BR33*YR33 C Squares of maximum phase-space coordinate differences RAM(I+19)=2.*ANULOG*AY11/BYDET RAM(I+20)=2.*ANULOG*AY22/BYDET RAM(I+21)=2.*ANULOG*AY33/BYDET RAM(I+22)=2.*ANULOG*(BY11+AR11/BYDET) RAM(I+23)=2.*ANULOG*(BY22+AR22/BYDET) RAM(I+24)=2.*ANULOG*(BY33+AR33/BYDET) C Halving the components of matrix K DO 51 I1=I+7,I+18 RAM(I1)=0.5*RAM(I1) 51 CONTINUE 52 CONTINUE END IF C C Check for the memory required for the calculation of the vector: IF(FRHS.NE.' '.AND.NQNSGF+N1N2N3.GT.MRAM) THEN C SGFMAT-11 CALL ERROR('SGFMAT-11: Too small array RAM for the grid') C The input parameters of Gabor functions and the input grid do C not fit together into array C RAM(MRAM). C The number of grid values is N1*N2*N3. C The number of parameters of each Gabor function is C 1-D: NQ=6 C 2-D: NQ=14 C 3-D: NQ=24 END IF C C....................................................................... C C Calculation of the symmetric matrix: IF(FMAT.NE.' ') THEN C C Preparation for storing the sparse matrix: NRAM=MRAM IMAT=NQNSGF+1 NELEM0=IMAT+2*NSGF NELEM=NELEM0 IRAM(IMAT)=NELEM0+1 DO 60 I=IMAT+1,NELEM IRAM(I)=0 60 CONTINUE C C Loops over Gabor functions: IF(NDIM.LE.3) THEN C 1-D: DO 112 ISGF2=0,NSGF-1 IF(MOD(ISGF2,50).EQ.0) THEN WRITE(*,'(2(A,I7),A,I3,A)') * '+SGFMAT: Matrix column',2*ISGF2,' of',2*NSGF, * ' (',NINT(100.*FLOAT(NELEM-NELEM0)/FLOAT(NRAM-NELEM0)), * '% RAM)' END IF IQ2=NQ*ISGF2 BX1=RAM(IQ2+1) BK1=RAM(IQ2+2) C Half matrix Yb BY11=RAM(IQ2+3) BYDET=BY11 C Half matrix Rb BR11=-RAM(IQ2+4) BXX1=RAM(IQ2+5) BKK1=RAM(IQ2+6) DO 111 ISGF1=0,ISGF2 IQ1=NQ*ISGF1 DX1=BX1-RAM(IQ1+1) IF(DX1*DX1.LE.RAM(IQ1+5)+BXX1) THEN AK1=RAM(IQ1+2) DK1=ABS(BK1)-ABS(AK1) ABKK1=RAM(IQ1+6)+BKK1 IF(DK1*DK1.LE.ABKK1) THEN GAGBR(1)=0.0 GAGBI(1)=0.0 GAGBR(2)=0.0 GAGBI(2)=0.0 C Half matrix Ya AY11=RAM(IQ1+3) AYDET=AY11 C Half matrix Ra AR11=-RAM(IQ1+4) C Real part of matrix Y YR11=BY11+AY11 C Imaginary part of matrix R RI11=BY11-AY11 DO 110 I=1,2 IF(I.EQ.2) THEN AK1=-AK1 END IF DK1=BK1-AK1 IF(DK1*DK1.LE.ABKK1) THEN IF(I.EQ.2) THEN AR11=-AR11 END IF C Imaginary part of matrix Y YI11=AR11-BR11 C Real part of matrix R RR11=AR11+BR11 C Determinant of matrix Y YDETR=YR11 YDETI=YI11 YDET2=YDETR*YDETR+YDETI*YDETI C Products of matrices and vectors RDXR1=RR11*DX1-DK1 RDXI1=RI11*DX1 DXZDXR=RDXR1*RDXR1-RDXI1*RDXI1 DXZDXI=RDXR1*RDXI1+RDXI1*RDXR1 C Real part of the exponent of scalar product EXPR=(DXZDXR*YDETR+DXZDXI*YDETI)/YDET2 EXPR=EXPR+DX1*YR11*DX1 EXPR=0.25*EXPR IF(EXPR.LE.ANULOG) THEN C Imaginary part of the exponent of scalar product EXPI=(DXZDXI*YDETR-DXZDXR*YDETI)/YDET2 EXPI=EXPI+DX1*YI11*DX1 EXPI=0.25*EXPI EXPI=EXPI+0.5*(BK1+AK1)*DX1 C=COS(-EXPI) S=SIN(-EXPI) C Square root of the determinant of matrix Y C (YDSQR^2-YDSQI^2=YDETR, 2*YDSQR*YDSQI=YDETI) YDSQ2=SQRT(YDET2) YDSQR=SQRT(0.5*(YDSQ2+YDETR)) YDSQI=SQRT(0.5*(YDSQ2-YDETR)) YDSQI=SIGN(YDSQI,YDETI) C Calculation of scalar product (ga,gb) AUX=EXP(-EXPR)/YDSQ2 GAGBR(I)=(YDSQR*C+YDSQI*S)*AUX GAGBI(I)=(YDSQR*S-YDSQI*C)*AUX END IF END IF 110 CONTINUE C C Storing the elements of the sparse matrix: C (ra-iya,rb+iyb)=(ra,rb)+(ya,yb)+i[(ra,yb)-(ya,rb)] C (ra+iya,rb+iyb)=(ra,rb)-(ya,yb)+i[(ra,yb)+(ya,rb)] AUX=2.0*SQRT(2.0*SQRT(AYDET*BYDET)) VALMIN=2.0*ANULL C Storing (2ra,2rb) I1=2*ISGF1+1 I2=2*ISGF2+1 VALUE=AUX*(GAGBR(1)+GAGBR(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) C Storing (-2ya,2rb) I1=I1+1 IF(ISGF1.NE.ISGF2) THEN VALUE=AUX*(GAGBI(1)-GAGBI(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) END IF C Storing (2ra,-2yb) I1=I1-1 I2=I2+1 VALUE=-AUX*(GAGBI(1)+GAGBI(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) C Storing (-2ya,-2yb) I1=I1+1 VALUE=AUX*(GAGBR(1)-GAGBR(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) END IF END IF 111 CONTINUE 112 CONTINUE ELSE IF(NDIM.LE.6) THEN C 2-D: DO 122 ISGF2=0,NSGF-1 IF(MOD(ISGF2,50).EQ.0) THEN WRITE(*,'(2(A,I7),A,I3,A)') * '+SGFMAT: Matrix column',2*ISGF2,' of',2*NSGF, * ' (',NINT(100.*FLOAT(NELEM-NELEM0)/FLOAT(NRAM-NELEM0)), * '% RAM)' END IF IQ2=NQ*ISGF2 BX1=RAM(IQ2+1) BX2=RAM(IQ2+2) BK1=RAM(IQ2+3) BK2=RAM(IQ2+4) C Half matrix Yb BY11=RAM(IQ2+5) BY12=RAM(IQ2+6) BY22=RAM(IQ2+7) BYDET=BY11*BY22-BY12*BY12 C Half matrix Rb BR11=-RAM(IQ2+8) BR12=-RAM(IQ2+9) BR22=-RAM(IQ2+10) BXX1=RAM(IQ2+11) BXX2=RAM(IQ2+12) BKK1=RAM(IQ2+13) BKK2=RAM(IQ2+14) DO 121 ISGF1=0,ISGF2 IQ1=NQ*ISGF1 DX1=BX1-RAM(IQ1+1) IF(DX1*DX1.LE.RAM(IQ1+11)+BXX1) THEN DX2=BX2-RAM(IQ1+2) IF(DX2*DX2.LE.RAM(IQ1+12)+BXX2) THEN AK1=RAM(IQ1+3) AK2=RAM(IQ1+4) DK1=ABS(BK1)-ABS(AK1) ABKK1=RAM(IQ1+13)+BKK1 IF(DK1*DK1.LE.ABKK1) THEN DK2=ABS(BK2)-ABS(AK2) ABKK2=RAM(IQ1+14)+BKK2 IF(DK2*DK2.LE.ABKK2) THEN GAGBR(1)=0.0 GAGBI(1)=0.0 GAGBR(2)=0.0 GAGBI(2)=0.0 C Half matrix Ya AY11=RAM(IQ1+5) AY12=RAM(IQ1+6) AY22=RAM(IQ1+7) AYDET=AY11*AY22-AY12*AY12 C Half matrix Ra AR11=-RAM(IQ1+8) AR12=-RAM(IQ1+9) AR22=-RAM(IQ1+10) C Real part of matrix Y YR11=BY11+AY11 YR12=BY12+AY12 YR22=BY22+AY22 C Imaginary part of matrix R RI11=BY11-AY11 RI12=BY12-AY12 RI22=BY22-AY22 DO 120 I=1,2 IF(I.EQ.2) THEN AK1=-AK1 AK2=-AK2 END IF DK1=BK1-AK1 IF(DK1*DK1.LE.ABKK1) THEN DK2=BK2-AK2 IF(DK2*DK2.LE.ABKK2) THEN IF(I.EQ.2) THEN AR11=-AR11 AR12=-AR12 AR22=-AR22 END IF C Imaginary part of matrix Y YI11=AR11-BR11 YI12=AR12-BR12 YI22=AR22-BR22 C Real part of matrix R RR11=AR11+BR11 RR12=AR12+BR12 RR22=AR22+BR22 C Inverse matrix to Y multiplied by det(Y) ZR11=YR22 ZR12=-YR12 ZR22=YR11 ZI11=YI22 ZI12=-YI12 ZI22=YI11 C Determinant of matrix Y YDETR=YR11*YR22-YI11*YI22-YR12*YR12+YI12*YI12 YDETI=YR11*YI22+YI11*YR22-YR12*YI12-YI12*YR12 YDET2=YDETR*YDETR+YDETI*YDETI C Products of matrices and vectors RDXR1=RR11*DX1+RR12*DX2-DK1 RDXR2=RR12*DX1+RR22*DX2-DK2 RDXI1=RI11*DX1+RI12*DX2 RDXI2=RI12*DX1+RI22*DX2 ZRDXR1=ZR11*RDXR1+ZR12*RDXR2 * -ZI11*RDXI1-ZI12*RDXI2 ZRDXR2=ZR12*RDXR1+ZR22*RDXR2 * -ZI12*RDXI1-ZI22*RDXI2 ZRDXI1=ZR11*RDXI1+ZR12*RDXI2 * +ZI11*RDXR1+ZI12*RDXR2 ZRDXI2=ZR12*RDXI1+ZR22*RDXI2 * +ZI12*RDXR1+ZI22*RDXR2 DXZDXR=RDXR1*ZRDXR1+RDXR2*ZRDXR2 * -RDXI1*ZRDXI1-RDXI2*ZRDXI2 DXZDXI=RDXR1*ZRDXI1+RDXR2*ZRDXI2 * +RDXI1*ZRDXR1+RDXI2*ZRDXR2 C Real part of the exponent of scalar product EXPR=(DXZDXR*YDETR+DXZDXI*YDETI)/YDET2 EXPR=EXPR+DX1*(YR11*DX1+2.*YR12*DX2) EXPR=EXPR+DX2* YR22*DX2 EXPR=0.25*EXPR IF(EXPR.LE.ANULOG) THEN C Imaginary part of the exponent of scalar product EXPI=(DXZDXI*YDETR-DXZDXR*YDETI)/YDET2 EXPI=EXPI+DX1*(YI11*DX1+2.* YI12*DX2) EXPI=EXPI+DX2* YI22*DX2 EXPI=0.25*EXPI EXPI=EXPI+0.5*((BK1+AK1)*DX1+(BK2+AK2)*DX2) C=COS(-EXPI) S=SIN(-EXPI) C Square root of the determinant of matrix Y C (YDSQR^2-YDSQI^2=YDETR, 2*YDSQR*YDSQI=YDETI) YDSQ2=SQRT(YDET2) YDSQR=SQRT(0.5*(YDSQ2+YDETR)) YDSQI=SQRT(0.5*(YDSQ2-YDETR)) YDSQI=SIGN(YDSQI,YDETI) C Calculation of scalar product (ga,gb) AUX=EXP(-EXPR)/YDSQ2 GAGBR(I)=(YDSQR*C+YDSQI*S)*AUX GAGBI(I)=(YDSQR*S-YDSQI*C)*AUX END IF END IF END IF 120 CONTINUE C C Storing the elements of the sparse matrix: C (ra-iya,rb+iyb)=(ra,rb)+(ya,yb)+i[(ra,yb)-(ya,rb)] C (ra+iya,rb+iyb)=(ra,rb)-(ya,yb)+i[(ra,yb)+(ya,rb)] AUX=2.0*SQRT(4.0*SQRT(AYDET*BYDET)) VALMIN=2.0*ANULL C Storing (2ra,2rb) I1=2*ISGF1+1 I2=2*ISGF2+1 VALUE=AUX*(GAGBR(1)+GAGBR(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) C Storing (-2ya,2rb) I1=I1+1 IF(ISGF1.NE.ISGF2) THEN VALUE=AUX*(GAGBI(1)-GAGBI(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) END IF C Storing (2ra,-2yb) I1=I1-1 I2=I2+1 VALUE=-AUX*(GAGBI(1)+GAGBI(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) C Storing (-2ya,-2yb) I1=I1+1 VALUE=AUX*(GAGBR(1)-GAGBR(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) END IF END IF END IF END IF 121 CONTINUE 122 CONTINUE ELSE C 3-D: DO 132 ISGF2=0,NSGF-1 IF(MOD(ISGF2,50).EQ.0) THEN WRITE(*,'(2(A,I7),A,I3,A)') * '+SGFMAT: Matrix column',2*ISGF2,' of',2*NSGF, * ' (',NINT(100.*FLOAT(NELEM-NELEM0)/FLOAT(NRAM-NELEM0)), * '% RAM)' END IF IQ2=NQ*ISGF2 BX1=RAM(IQ2+1) BX2=RAM(IQ2+2) BX3=RAM(IQ2+3) BK1=RAM(IQ2+4) BK2=RAM(IQ2+5) BK3=RAM(IQ2+6) C Half matrix Yb BY11=RAM(IQ2+7) BY12=RAM(IQ2+8) BY22=RAM(IQ2+9) BY13=RAM(IQ2+10) BY23=RAM(IQ2+11) BY33=RAM(IQ2+12) BYDET=BY11*(BY22*BY33-BY23*BY23) * +BY12*(BY13*BY23-BY33*BY12) * +BY13*(BY12*BY23-BY22*BY13) C Half matrix Rb BR11=-RAM(IQ2+13) BR12=-RAM(IQ2+14) BR22=-RAM(IQ2+15) BR13=-RAM(IQ2+16) BR23=-RAM(IQ2+17) BR33=-RAM(IQ2+18) BXX1=RAM(IQ2+19) BXX2=RAM(IQ2+20) BXX3=RAM(IQ2+21) BKK1=RAM(IQ2+22) BKK2=RAM(IQ2+23) BKK3=RAM(IQ2+24) DO 131 ISGF1=0,ISGF2 IQ1=NQ*ISGF1 DX1=BX1-RAM(IQ1+1) IF(DX1*DX1.LE.RAM(IQ1+19)+BXX1) THEN DX2=BX2-RAM(IQ1+2) IF(DX2*DX2.LE.RAM(IQ1+20)+BXX2) THEN DX3=BX3-RAM(IQ1+3) IF(DX3*DX3.LE.RAM(IQ1+21)+BXX3) THEN AK1=RAM(IQ1+4) AK2=RAM(IQ1+5) AK3=RAM(IQ1+6) DK1=ABS(BK1)-ABS(AK1) ABKK1=RAM(IQ1+22)+BKK1 IF(DK1*DK1.LE.ABKK1) THEN DK2=ABS(BK2)-ABS(AK2) ABKK2=RAM(IQ1+23)+BKK2 IF(DK2*DK2.LE.ABKK2) THEN DK3=ABS(BK3)-ABS(AK3) ABKK3=RAM(IQ1+24)+BKK3 IF(DK3*DK3.LE.ABKK3) THEN GAGBR(1)=0.0 GAGBI(1)=0.0 GAGBR(2)=0.0 GAGBI(2)=0.0 C Half matrix Ya AY11=RAM(IQ1+7) AY12=RAM(IQ1+8) AY22=RAM(IQ1+9) AY13=RAM(IQ1+10) AY23=RAM(IQ1+11) AY33=RAM(IQ1+12) AYDET=AY11*(AY22*AY33-AY23*AY23) * +AY12*(AY13*AY23-AY33*AY12) * +AY13*(AY12*AY23-AY22*AY13) C Half matrix Ra AR11=-RAM(IQ1+13) AR12=-RAM(IQ1+14) AR22=-RAM(IQ1+15) AR13=-RAM(IQ1+16) AR23=-RAM(IQ1+17) AR33=-RAM(IQ1+18) C Real part of matrix Y YR11=BY11+AY11 YR12=BY12+AY12 YR22=BY22+AY22 YR13=BY13+AY13 YR23=BY23+AY23 YR33=BY33+AY33 C Imaginary part of matrix R RI11=BY11-AY11 RI12=BY12-AY12 RI22=BY22-AY22 RI13=BY13-AY13 RI23=BY23-AY23 RI33=BY33-AY33 DO 130 I=1,2 IF(I.EQ.2) THEN AK1=-AK1 AK2=-AK2 AK3=-AK3 END IF DK1=BK1-AK1 IF(DK1*DK1.LE.ABKK1) THEN DK2=BK2-AK2 IF(DK2*DK2.LE.ABKK2) THEN DK3=BK3-AK3 IF(DK3*DK3.LE.ABKK3) THEN IF(I.EQ.2) THEN AR11=-AR11 AR12=-AR12 AR22=-AR22 AR13=-AR13 AR23=-AR23 AR33=-AR33 END IF C Imaginary part of matrix Y YI11=AR11-BR11 YI12=AR12-BR12 YI22=AR22-BR22 YI13=AR13-BR13 YI23=AR23-BR23 YI33=AR33-BR33 C Real part of matrix R RR11=AR11+BR11 RR12=AR12+BR12 RR22=AR22+BR22 RR13=AR13+BR13 RR23=AR23+BR23 RR33=AR33+BR33 C Inverse matrix to Y multiplied by det(Y) ZR11=YR22*YR33-YR23*YR23-YI22*YI33+YI23*YI23 ZR12=YR13*YR23-YR12*YR33-YI13*YI23+YI12*YI33 ZR22=YR11*YR33-YR13*YR13-YI11*YI33+YI13*YI13 ZR13=YR12*YR23-YR13*YR22-YI12*YI23+YI13*YI22 ZR23=YR12*YR13-YR23*YR11-YI12*YI13+YI23*YI11 ZR33=YR11*YR22-YR12*YR12-YI11*YI22+YI12*YI12 ZI11=YR22*YI33-YR23*YI23+YI22*YR33-YI23*YR23 ZI12=YR13*YI23-YR12*YI33+YI13*YR23-YI12*YR33 ZI22=YR11*YI33-YR13*YI13+YI11*YR33-YI13*YR13 ZI13=YR12*YI23-YR13*YI22+YI12*YR23-YI13*YR22 ZI23=YR12*YI13-YR23*YI11+YI12*YR13-YI23*YR11 ZI33=YR11*YI22-YR12*YI12+YI11*YR22-YI12*YR12 C Determinant of matrix Y YDETR=ZR11*YR11+ZR12*YR12+ZR13*YR13 * -ZI11*YI11-ZI12*YI12-ZI13*YI13 YDETI=ZR11*YI11+ZR12*YI12+ZR13*YI13 * +ZI11*YR11+ZI12*YR12+ZI13*YR13 YDET2=YDETR*YDETR+YDETI*YDETI C Products of matrices and vectors RDXR1=RR11*DX1+RR12*DX2+RR13*DX3-DK1 RDXR2=RR12*DX1+RR22*DX2+RR23*DX3-DK2 RDXR3=RR13*DX1+RR23*DX2+RR33*DX3-DK3 RDXI1=RI11*DX1+RI12*DX2+RI13*DX3 RDXI2=RI12*DX1+RI22*DX2+RI23*DX3 RDXI3=RI13*DX1+RI23*DX2+RI33*DX3 ZRDXR1=ZR11*RDXR1+ZR12*RDXR2+ZR13*RDXR3 * -ZI11*RDXI1-ZI12*RDXI2-ZI13*RDXI3 ZRDXR2=ZR12*RDXR1+ZR22*RDXR2+ZR23*RDXR3 * -ZI12*RDXI1-ZI22*RDXI2-ZI23*RDXI3 ZRDXR3=ZR13*RDXR1+ZR23*RDXR2+ZR33*RDXR3 * -ZI13*RDXI1-ZI23*RDXI2-ZI33*RDXI3 ZRDXI1=ZR11*RDXI1+ZR12*RDXI2+ZR13*RDXI3 * +ZI11*RDXR1+ZI12*RDXR2+ZI13*RDXR3 ZRDXI2=ZR12*RDXI1+ZR22*RDXI2+ZR23*RDXI3 * +ZI12*RDXR1+ZI22*RDXR2+ZI23*RDXR3 ZRDXI3=ZR13*RDXI1+ZR23*RDXI2+ZR33*RDXI3 * +ZI13*RDXR1+ZI23*RDXR2+ZI33*RDXR3 DXZDXR=RDXR1*ZRDXR1+RDXR2*ZRDXR2+RDXR3*ZRDXR3 * -RDXI1*ZRDXI1-RDXI2*ZRDXI2-RDXI3*ZRDXI3 DXZDXI=RDXR1*ZRDXI1+RDXR2*ZRDXI2+RDXR3*ZRDXI3 * +RDXI1*ZRDXR1+RDXI2*ZRDXR2+RDXI3*ZRDXR3 C Real part of the exponent of scalar product EXPR=(DXZDXR*YDETR+DXZDXI*YDETI)/YDET2 EXPR=EXPR+DX1*(YR11*DX1+2.*(YR12*DX2+YR13*DX3)) EXPR=EXPR+DX2*(YR22*DX2+2.* YR23*DX3) EXPR=EXPR+DX3* YR33*DX3 EXPR=0.25*EXPR IF(EXPR.LE.ANULOG) THEN C Imaginary part of the exponent of scalar product EXPI=(DXZDXI*YDETR-DXZDXR*YDETI)/YDET2 EXPI=EXPI+DX1*(YI11*DX1+2.*(YI12*DX2+YI13*DX3)) EXPI=EXPI+DX2*(YI22*DX2+2.* YI23*DX3) EXPI=EXPI+DX3* YI33*DX3 EXPI=0.25*EXPI EXPI=EXPI+0.5*((BK1+AK1)*DX1+(BK2+AK2)*DX2 * +(BK3+AK3)*DX3) C=COS(-EXPI) S=SIN(-EXPI) C Square root of the determinant of matrix Y C (YDSQR^2-YDSQI^2=YDETR, 2*YDSQR*YDSQI=YDETI) YDSQ2=SQRT(YDET2) YDSQR=SQRT(0.5*(YDSQ2+YDETR)) YDSQI=SQRT(0.5*(YDSQ2-YDETR)) YDSQI=SIGN(YDSQI,YDETI) IF(YDETR.LE.0.0) THEN IF(YDSQI*(ZI11+ZI22+ZI33).LT.0.0) THEN YDSQR=-YDSQR YDSQI=-YDSQI END IF END IF C Calculation of scalar product (ga,gb) AUX=EXP(-EXPR)/YDSQ2 GAGBR(I)=(YDSQR*C+YDSQI*S)*AUX GAGBI(I)=(YDSQR*S-YDSQI*C)*AUX END IF END IF END IF END IF 130 CONTINUE C C Storing the elements of the sparse matrix: C (ra-iya,rb+iyb)=(ra,rb)+(ya,yb)+i[(ra,yb)-(ya,rb)] C (ra+iya,rb+iyb)=(ra,rb)-(ya,yb)+i[(ra,yb)+(ya,rb)] AUX=2.0*SQRT(8.0*SQRT(AYDET*BYDET)) VALMIN=2.0*ANULL C Storing (2ra,2rb) I1=2*ISGF1+1 I2=2*ISGF2+1 VALUE=AUX*(GAGBR(1)+GAGBR(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) C Storing (-2ya,2rb) I1=I1+1 IF(ISGF1.NE.ISGF2) THEN VALUE=AUX*(GAGBI(1)-GAGBI(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) END IF C Storing (2ra,-2yb) I1=I1-1 I2=I2+1 VALUE=-AUX*(GAGBI(1)+GAGBI(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) C Storing (-2ya,-2yb) I1=I1+1 VALUE=AUX*(GAGBR(1)-GAGBR(2)) CALL STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) END IF END IF END IF END IF END IF END IF 131 CONTINUE 132 CONTINUE END IF NELEM=NELEM-NELEM0 NELEM=NELEM/2 C NELEM is the number of non-zero elements of the sparse matrix. C C Writing the output sparse matrix: WRITE(*,'(A)') '+SGFMAT: Writing... ' FDAT=' ' SPARSE='CSC' SYMM='sym' FORM=' ' CALL WMATH(LU1,FMAT,FDAT,2*NSGF,2*NSGF,SPARSE,NELEM,SYMM,FORM) CALL WMATD(LU1,FDAT,2*NSGF,2*NSGF,SPARSE,NELEM,FORM,IMAT) C END IF C C....................................................................... C C Calculation of the vector: IF(FRHS.NE.' ') THEN FORM='FORMATTED' CALL RARRAY(LU1,FGRD,FORM,.TRUE.,0.0,N1N2N3,RAM(NQNSGF+1)) C IF(NDIM.LE.3) THEN C 1-D: DO 214 ISGF2=0,NSGF-1 IF(MOD(ISGF2,50).EQ.0) THEN WRITE(*,'(2(A,I7))') * '+SGFMAT: Vector component',2*ISGF2,' of',2*NSGF END IF C Initalizing the integrals SUMR=0.0 SUMI=0.0 C Quantities describing the Gabor function IQ2=NQ*ISGF2 BX1=RAM(IQ2+1) BK1=RAM(IQ2+2) C Half matrix Y BY11=RAM(IQ2+3) C Half matrix R BR11=-RAM(IQ2+4) C Determinant of half matrix Y BYDET=BY11 C Extent of the Gabor function along axis X1 AUX=SQRT(RELLOG/BY11) J1=MAX0(INT((BX1-AUX)/D1+0.999),0) K1=MIN0(INT((BX1+AUX)/D1+0.001),N1-1) IF(J1.LE.K1) THEN C Index of the central point along the gridline M1=MAX0(J1,MIN0(NINT(BX1/D1),K1)) C Relative coordinate of the central point DX1=O1+D1*FLOAT(M1)-BX1 C Exponent at the central point EXP0R=DX1*BY11*DX1 EXP0I=DX1*(BK1+BR11*DX1) C The first derivative of the exponent EXP1R=BY11*DX1 EXP1I=BR11*DX1 EXP1R=D1*(EXP1R+EXP1R) EXP1I=D1*(EXP1I+EXP1I+BK1) C Half the second derivative of the exponent EXP2R=D1*BY11*D1 EXP2I=D1*BR11*D1 C Half the second derivative minus the first derivative EXP1MR=EXP2R-EXP1R EXP1MI=EXP2I-EXP1I C Half the second derivative plus the first derivative EXP1R=EXP2R+EXP1R EXP1I=EXP2I+EXP1I C Second derivative of the exponent EXP2R=EXP2R+EXP2R EXP2I=EXP2I+EXP2I C Exponential function at the central point AUX=EXP(-EXP0R) C=COS(EXP0I) S=SIN(EXP0I) EXP0R=C*AUX EXP0I=S*AUX C Exponential correction at the central point (+) AUX=EXP(-EXP1R) C=COS(EXP1I) S=SIN(EXP1I) EXP1R=C*AUX EXP1I=S*AUX C Exponential correction at the central point (-) AUX=EXP(-EXP1MR) C=COS(EXP1MI) S=SIN(EXP1MI) EXP1MR=C*AUX EXP1MI=S*AUX C Constant correction to the correction AUX=EXP(-EXP2R) C=COS(EXP2I) S=SIN(EXP2I) EXP2R=C*AUX EXP2I=S*AUX C C Contribution to the integral at the central point I=NQNSGF+1+M1 AUX=RAM(I) SUMR=SUMR+AUX*EXP0R SUMI=SUMI+AUX*EXP0I C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C* Test for debugging * WRITE(*,*) C* C Loop over the gridpoints DO 210 I1=I+1,I+K1-M1 C* Test for debugging * DX1=O1+D1*FLOAT(I1-I-1+M1)-BX1 * CHKR=DX1*BY11*DX1 * CHKI=DX1*(BK1+BR11*DX1) * AUX=EXP(-CHKR) * C=COS(CHKI) * S=SIN(CHKI) * CHKR=C*AUX * CHKI=S*AUX * WRITE(*,*) CHKR,EXPR,CHKI,EXPI C* AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX AUX=RAM(I1) SUMR=SUMR+AUX*EXPR SUMI=SUMI+AUX*EXPI 210 CONTINUE C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Exponential correction at the central point EXP1R=EXP1MR EXP1I=EXP1MI C Loop over the gridpoints DO 211 I1=I-1,I+J1-M1,-1 AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX AUX=RAM(I1) SUMR=SUMR+AUX*EXPR SUMI=SUMI+AUX*EXPI 211 CONTINUE END IF AUX=2.0*D1*SQRT(SQRT(2.0*BYDET)/COEF1D) RAM(2*ISGF2+1)= AUX*SUMR RAM(2*ISGF2+2)=-AUX*SUMI 214 CONTINUE ELSE IF(NDIM.LE.6) THEN C 2-D: DO 224 ISGF2=0,NSGF-1 IF(MOD(ISGF2,50).EQ.0) THEN WRITE(*,'(2(A,I7))') * '+SGFMAT: Vector component',2*ISGF2,' of',2*NSGF END IF C Initalizing the integrals SUMR=0.0 SUMI=0.0 C Quantities describing the Gabor function IQ2=NQ*ISGF2 BX1=RAM(IQ2+1) BX2=RAM(IQ2+2) BK1=RAM(IQ2+3) BK2=RAM(IQ2+4) C Half matrix Y BY11=RAM(IQ2+5) BY12=RAM(IQ2+6) BY22=RAM(IQ2+7) C Half matrix R BR11=-RAM(IQ2+8) BR12=-RAM(IQ2+9) BR22=-RAM(IQ2+10) C Determinant of half matrix Y BYDET=BY11*BY22-BY12*BY12 C Extent of the Gabor function along axis X2 AUX=SQRT(RELLOG*BY11/BYDET) J2=MAX0(INT((BX2-AUX-O2)/D2+0.999),0) K2=MIN0(INT((BX2+AUX-O2)/D2+0.001),N2-1) DO 222 I2=J2,K2 DX2=O2+D2*FLOAT(I2)-BX2 C Extent of the Gabor function along axis X1 AUX=RELLOG-BY22*DX2*DX2 IF(AUX.GE.0.0) THEN C Halfwidth of the Gabor function along axis X1 AUX=SQRT(AUX/BY11) C Central point along the gridline DX1=BX1-BY12*DX2/BY11-O1 J1=MAX0(INT((DX1-AUX)/D1+0.999),0) K1=MIN0(INT((DX1+AUX)/D1+0.001),N1-1) IF(J1.LE.K1) THEN C Index of the central point along the gridline M1=MAX0(J1,MIN0(NINT(DX1/D1),K1)) C Relative coordinate of the central point DX1=O1+D1*FLOAT(M1)-BX1 C Exponent at the central point EXP0R=DX1*(BY11*DX1+2.0*BY12*DX2)+DX2*BY22*DX2 EXP0I= DX1*(BK1+BR11*DX1+2.0*BR12*DX2) EXP0I=EXP0I+DX2*(BK2+BR22*DX2) C The first derivative of the exponent EXP1R=BY11*DX1+BY12*DX2 EXP1I=BR11*DX1+BR12*DX2 EXP1R=D1*(EXP1R+EXP1R) EXP1I=D1*(EXP1I+EXP1I+BK1) C Half the second derivative of the exponent EXP2R=D1*BY11*D1 EXP2I=D1*BR11*D1 C Half the second derivative minus the first derivative EXP1MR=EXP2R-EXP1R EXP1MI=EXP2I-EXP1I C Half the second derivative plus the first derivative EXP1R=EXP2R+EXP1R EXP1I=EXP2I+EXP1I C Second derivative of the exponent EXP2R=EXP2R+EXP2R EXP2I=EXP2I+EXP2I C Exponential function at the central point AUX=EXP(-EXP0R) C=COS(EXP0I) S=SIN(EXP0I) EXP0R=C*AUX EXP0I=S*AUX C Exponential correction at the central point (+) AUX=EXP(-EXP1R) C=COS(EXP1I) S=SIN(EXP1I) EXP1R=C*AUX EXP1I=S*AUX C Exponential correction at the central point (-) AUX=EXP(-EXP1MR) C=COS(EXP1MI) S=SIN(EXP1MI) EXP1MR=C*AUX EXP1MI=S*AUX C Constant correction to the correction AUX=EXP(-EXP2R) C=COS(EXP2I) S=SIN(EXP2I) EXP2R=C*AUX EXP2I=S*AUX C C Contribution to the integral at the central point I=NQNSGF+1+M1+N1*I2 AUX=RAM(I) SUMR=SUMR+AUX*EXP0R SUMI=SUMI+AUX*EXP0I C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C* Test for debugging * WRITE(*,*) C* C Loop over the gridpoints DO 220 I1=I+1,I+K1-M1 C* Test for debugging * DX1=O1+D1*FLOAT(I1-I-1+M1)-BX1 * DX1=O1+D1*FLOAT(I1-I+M1)-BX1 * CHKR= DX1*(BY11*DX1+2.*BY12*DX2) * CHKR=CHKR+DX2* BY22*DX2 * CHKI= DX1*(BK1+BR11*DX1+2.*BR12*DX2) * CHKI=CHKI+DX2*(BK2+BR22*DX2) * AUX=EXP(-CHKR) * C=COS(CHKI) * S=SIN(CHKI) * CHKR=C*AUX * CHKI=S*AUX * WRITE(*,*) CHKR,EXPR,CHKI,EXPI * EXPR=CHKR * EXPI=CHKI C* AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX AUX=RAM(I1) SUMR=SUMR+AUX*EXPR SUMI=SUMI+AUX*EXPI 220 CONTINUE C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Exponential correction at the central point EXP1R=EXP1MR EXP1I=EXP1MI C* Test for debugging * WRITE(*,*) C* C Loop over the gridpoints DO 221 I1=I-1,I+J1-M1,-1 C* Test for debugging * DX1=O1+D1*FLOAT(I1-I+1+M1)-BX1 * DX1=O1+D1*FLOAT(I1-I+M1)-BX1 * CHKR= DX1*(BY11*DX1+2.*BY12*DX2) * CHKR=CHKR+DX2* BY22*DX2 * CHKI= DX1*(BK1+BR11*DX1+2.*BR12*DX2) * CHKI=CHKI+DX2*(BK2+BR22*DX2) * AUX=EXP(-CHKR) * C=COS(CHKI) * S=SIN(CHKI) * CHKR=C*AUX * CHKI=S*AUX * WRITE(*,*) CHKR,EXPR,CHKI,EXPI * EXPR=CHKR * EXPI=CHKI C* AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX AUX=RAM(I1) SUMR=SUMR+AUX*EXPR SUMI=SUMI+AUX*EXPI 221 CONTINUE END IF END IF 222 CONTINUE AUX=2.0*D1*D2*SQRT(SQRT(4.0*BYDET)/COEF2D) RAM(2*ISGF2+1)= AUX*SUMR RAM(2*ISGF2+2)=-AUX*SUMI 224 CONTINUE ELSE C 3-D: DO 234 ISGF2=0,NSGF-1 IF(MOD(ISGF2,50).EQ.0) THEN WRITE(*,'(2(A,I7))') * '+SGFMAT: Vector component',2*ISGF2,' of',2*NSGF END IF C Initalizing the integrals SUMR=0.0 SUMI=0.0 C Quantities describing the Gabor function IQ2=NQ*ISGF2 BX1=RAM(IQ2+1) BX2=RAM(IQ2+2) BX3=RAM(IQ2+3) BK1=RAM(IQ2+4) BK2=RAM(IQ2+5) BK3=RAM(IQ2+6) C Half matrix Y BY11=RAM(IQ2+7) BY12=RAM(IQ2+8) BY22=RAM(IQ2+9) BY13=RAM(IQ2+10) BY23=RAM(IQ2+11) BY33=RAM(IQ2+12) C Half matrix R BR11=-RAM(IQ2+13) BR12=-RAM(IQ2+14) BR22=-RAM(IQ2+15) BR13=-RAM(IQ2+16) BR23=-RAM(IQ2+17) BR33=-RAM(IQ2+18) C Determinant of the 2*2 submatrix of half Y DET=BY11*BY22-BY12*BY12 C Matrix inverse to the 2*2 submatrix of Y times (BY13,BY23) AY13=( BY22*BY13-BY12*BY23)/DET AY23=(-BY12*BY13+BY11*BY23)/DET C Determinant of half matrix Y BYDET=BY33*DET-BY11*BY23*BY23 * +BY13*(2.0*BY12*BY23-BY22*BY13) C Extent of the Gabor function along axis X3 AUX=SQRT(RELLOG*DET/BYDET) J3=MAX0(INT((BX3-AUX-O3)/D3+0.999),0) K3=MIN0(INT((BX3+AUX-O3)/D3+0.001),N3-1) DO 233 I3=J3,K3 DX3=O3+D3*FLOAT(I3)-BX3 C C Transforming 3-D Gabor packet to 2-D Gabor packet C Shift of the central point DX1=-AY13*DX3 DX2=-AY23*DX3 C Central point of the 2-D Gabor packet AX1=BX1+DX1 AX2=BX2+DX2 C Wavenumber vetor of the 2-D Gabor packet AK1=BK1+2.0*(BR11*DX1+BR12*DX2+BR13*DX3) AK2=BK2+2.0*(BR12*DX1+BR22*DX2+BR23*DX3) C Exponent of the 2-D Gabor packet at its central point AR33= DX1*(BK1+BR11*DX1+2.0*(BR12*DX2+BR13*DX3)) AR33=AR33+DX2*(BK2+BR22*DX2+2.0* BR23*DX3) AR33=AR33+DX3*(BK3+BR33*DX3) AY33=(BY33-BY13*AY13-BY23*AY23)*DX3*DX3 C Matrices BY11,BY12,BY22 and BR11,BR12,BR22 keep unchanged. C C Extent of the Gabor function along axis X2 AUX=RELLOG-AY33 IF(AUX.GE.0.0) THEN AUX=SQRT(AUX*BY11/DET) J2=MAX0(INT((AX2-AUX-O2)/D2+0.999),0) K2=MIN0(INT((AX2+AUX-O2)/D2+0.001),N2-1) DO 232 I2=J2,K2 DX2=O2+D2*FLOAT(I2)-AX2 C Extent of the Gabor function along axis X1 AUX=RELLOG-AY33-(DET/BY11)*DX2*DX2 IF(AUX.GE.0.0) THEN AUX=SQRT(AUX/BY11) DX1=AX1-BY12*DX2/BY11-O1 J1=MAX0(INT((DX1-AUX)/D1+0.999),0) K1=MIN0(INT((DX1+AUX)/D1+0.001),N1-1) IF(J1.LE.K1) THEN C Index of the central point along the gridline M1=MAX0(J1,MIN0(NINT(DX1/D1),K1)) C Relative coordinate of the central point DX1=O1+D1*FLOAT(M1)-AX1 C Exponent at the central point EXP0R=AY33 EXP0R=EXP0R+DX1*(BY11*DX1+2.0*BY12*DX2) EXP0R=EXP0R+DX2* BY22*DX2 EXP0I=AR33 EXP0I=EXP0I+DX1*(AK1+BR11*DX1+2.0*BR12*DX2) EXP0I=EXP0I+DX2*(AK2+BR22*DX2) C The first derivative of the exponent EXP1R=BY11*DX1+BY12*DX2 EXP1I=BR11*DX1+BR12*DX2 EXP1R=D1*(EXP1R+EXP1R) EXP1I=D1*(EXP1I+EXP1I+AK1) C Half the second derivative of the exponent EXP2R=D1*BY11*D1 EXP2I=D1*BR11*D1 C Half the second derivative minus first derivative EXP1MR=EXP2R-EXP1R EXP1MI=EXP2I-EXP1I C Half the second derivative plus first derivative EXP1R=EXP2R+EXP1R EXP1I=EXP2I+EXP1I C Second derivative of the exponent EXP2R=EXP2R+EXP2R EXP2I=EXP2I+EXP2I C Exponential function at the central point AUX=EXP(-EXP0R) C=COS(EXP0I) S=SIN(EXP0I) EXP0R=C*AUX EXP0I=S*AUX C Exponential correction at the central point (+) AUX=EXP(-EXP1R) C=COS(EXP1I) S=SIN(EXP1I) EXP1R=C*AUX EXP1I=S*AUX C Exponential correction at the central point (-) AUX=EXP(-EXP1MR) C=COS(EXP1MI) S=SIN(EXP1MI) EXP1MR=C*AUX EXP1MI=S*AUX C Constant correction to the correction AUX=EXP(-EXP2R) C=COS(EXP2I) S=SIN(EXP2I) EXP2R=C*AUX EXP2I=S*AUX C C Contribution to the integral at the central point I=NQNSGF+1+M1+N1*(I2+N2*I3) AUX=RAM(I) SUMR=SUMR+AUX*EXP0R SUMI=SUMI+AUX*EXP0I C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C* Test for debugging * WRITE(*,*) * DX2=O2+D2*FLOAT(I2)-BX2 C* C Loop over the gridpoints DO 230 I1=I+1,I+K1-M1 C* Test for debugging * DX1=O1+D1*FLOAT(I1-I-1+M1)-BX1 * CHKR= DX1*(BY11*DX1+2.*(BY12*DX2+BY13*DX3)) * CHKR=CHKR+DX2*(BY22*DX2+2.* BY23*DX3) * CHKR=CHKR+DX3* BY33*DX3 * CHKI=BK1*DX1+BK2*DX2+BK3*DX3 * CHKI=CHKI+DX1*(BR11*DX1+2.*(BR12*DX2+BR13*DX3)) * CHKI=CHKI+DX2*(BR22*DX2+2.* BR23*DX3) * CHKI=CHKI+DX3* BR33*DX3 * AUX=EXP(-CHKR) * C=COS(CHKI) * S=SIN(CHKI) * CHKR=C*AUX * CHKI=S*AUX * WRITE(*,*) CHKR,EXPR,CHKI,EXPI C* AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX AUX=RAM(I1) SUMR=SUMR+AUX*EXPR SUMI=SUMI+AUX*EXPI 230 CONTINUE C C Exponential function at the central point EXPR=EXP0R EXPI=EXP0I C Exponential correction at the central point EXP1R=EXP1MR EXP1I=EXP1MI C* Test for debugging * WRITE(*,*) * DX2=O2+D2*FLOAT(I2)-BX2 C* C Loop over the gridpoints DO 231 I1=I-1,I+J1-M1,-1 C* Test for debugging * DX1=O1+D1*FLOAT(I1-I+1+M1)-BX1 * CHKR= DX1*(BY11*DX1+2.*(BY12*DX2+BY13*DX3)) * CHKR=CHKR+DX2*(BY22*DX2+2.* BY23*DX3) * CHKR=CHKR+DX3* BY33*DX3 * CHKI=BK1*DX1+BK2*DX2+BK3*DX3 * CHKI=CHKI+DX1*(BR11*DX1+2.*(BR12*DX2+BR13*DX3)) * CHKI=CHKI+DX2*(BR22*DX2+2.* BR23*DX3) * CHKI=CHKI+DX3* BR33*DX3 * AUX=EXP(-CHKR) * C=COS(CHKI) * S=SIN(CHKI) * CHKR=C*AUX * CHKI=S*AUX * WRITE(*,*) CHKR,EXPR,CHKI,EXPI C* AUX =EXPR*EXP1R-EXPI*EXP1I EXPI=EXPR*EXP1I+EXPI*EXP1R EXPR=AUX AUX =EXP1R*EXP2R-EXP1I*EXP2I EXP1I=EXP1R*EXP2I+EXP1I*EXP2R EXP1R=AUX AUX=RAM(I1) SUMR=SUMR+AUX*EXPR SUMI=SUMI+AUX*EXPI 231 CONTINUE END IF END IF 232 CONTINUE END IF 233 CONTINUE AUX=2.0*D1*D2*D3*SQRT(SQRT(8.0*BYDET)/COEF3D) RAM(2*ISGF2+1)= AUX*SUMR RAM(2*ISGF2+2)=-AUX*SUMI 234 CONTINUE END IF C C Writing the output vector: WRITE(*,'(A)') '+SGFMAT: Writing... ' FDAT=' ' SPARSE=' ' SYMM=' ' FORM=' ' CALL WMATH(LU1,FRHS,FDAT,2*NSGF,1,SPARSE,2*NSGF,SYMM,FORM) CALL WMATD(LU1,FDAT,2*NSGF,1,SPARSE,2*NSGF,FORM,1) C END IF C WRITE(*,'(A)') '+SGFMAT: Done. ' STOP END C C======================================================================= C C C SUBROUTINE STORE(I1,I2,VALUE,VALMIN,IMAT,NELEM,NRAM) INTEGER I1,I2,IMAT,NELEM,NRAM REAL VALUE,VALMIN C C Subroutine storing a given matrix element into arrays IRAM and RAM. C C Input: C I1... Row index of the element of a sparse matrix. C I2... Column index of the element of a sparse matrix. C VALUE.. Value of the element of a sparse matrix. C VALMIN. Minimim value for storing. C If ABS(VALUE).LT.VALMIN, nothing is stored. C IMAT... Address of the first storage location of the matrix C in array RAM of common block /RAMC/. C NELEM.. Index of the last stored value in array RAM. C NRAM... Dimension of the usable part of array RAM. C C Output if ABS(VALUE).GE.VALMIN: C NELEM.. Input value increased by 2. C Array RAM of common block /RAMC/ is updated. C C No output if ABS(VALUE).LT.VALMIN. C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of working array: INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C External functions and subroutines: EXTERNAL ERROR C C Auxiliary storage locations: INTEGER I,J C C----------------------------------------------------------------------- C IF(ABS(VALUE).GE.VALMIN) THEN IF(NELEM+2.GT.NRAM) THEN C SGFMAT-12 CALL ERROR('SGFMAT-12: Too small array RAM for the matrix') C The input parameters of Gabor functions and the elements C of the sparse symmetric matrix do not fit into array C RAM(MRAM). C The number of parameters of each Gabor function is C 1-D: NQ=6 C 2-D: NQ=14 C 3-D: NQ=24 C Dimension MRAM of array RAM should be at least NQ*NSF+3*NELEM, C where NSF is the number of odd Gabor functions and C NELEM is the number of non-zero elements of the sparse C symmetric matrix. C You may increase the value of input SEP parameter NULL, C increase dimension C MRAM and recompile C the program, or decrease the number of input Gabor functions. END IF NELEM=NELEM+2 C C Updating the length of the column I=IRAM(IMAT+I2) IF(I.EQ.0) THEN I=IRAM(IMAT+I2-1) IF(I.EQ.0) THEN I=IRAM(IMAT+I2-2) IF(I.EQ.0) THEN C SGFMAT-13 CALL ERROR('SGFMAT-13: Zero column of the matrix') C This error should not appear. Contact the authors. END IF IRAM(IMAT+I2-1)=I END IF END IF IRAM(IMAT+I2)=I+2 C C Moving the already stored elements of the next column J=IMAT+I2+1 IF(J.LT.IRAM(IMAT)) THEN J=IRAM(J) IF(J.NE.0) THEN IRAM(IMAT+I2+1)=J+2 DO 10 J=J,I+2,-2 IRAM(J )=IRAM(J-2) RAM (J+1)=RAM (J-1) 10 CONTINUE END IF END IF C C Storing the matrix element IRAM(I )=I1 RAM (I+1)=VALUE END IF RETURN 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 'mat.for' C mat.for C C======================================================================= Csinv.for 0100666 0000765 0000765 00000007456 10444173556 012145 0 ustar bulant bulant C
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======================================================================= Csmeigen.for 0100666 0000765 0000765 00000024465 11024140020 012563 0 ustar bulant bulant C
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: 6.20 C Date: 2008, 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 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 matrix header files: C SM1='string' ... Name of the header file of the input symmetric C matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C GM1='string' ... Name of the header file of the general C matrix of eigenvectors of matrix SM1 (output). C Default: GM1=' ' (the matrix is not written). C DM1='string' ... Name of the header file of the 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 Recent version of the program cannot deal with sparse matrices. C For general description of the files with matrices refer to file C forms.htm. C Form of the output files with matrices: C FORMM='string' ... Form of the output files with matrices. Allowed C values are FORMM='formatted' and FORMM='unformatted'. 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 C eigennr.for. C ERROR ... File error.for. C RSEP1,RSEP3T ... File C sep.for. C RMAT,WMAT ... File C 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 'mat.for' C mat.for INCLUDE 'indexi.for' C indexi.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======================================================================= Csmpower.for 0100666 0000765 0000765 00000024367 11024140020 012631 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: 6.20 C Date: 2008, 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 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 matrix header files: C SM1='string' ... Name of the header file of the symmetric C matrix SM1. C No default, 'SM1' must be specified and cannot be blank. C SM2='string' ... Name of the header file of the symmetric C matrix SM2=SM1**POWER. C No default, 'SM2' must be specified and cannot be blank. C Recent version of the program cannot deal with sparse matrices. C For general description of the files with matrices refer to file C forms.htm. C Form of the output data file with matrix SM1: C FORMM='string' ... Form of the output files with matrices. Allowed C values are FORMM='formatted' and FORMM='unformatted'. 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 C mat.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 'mat.for' C mat.for INCLUDE 'indexi.for' C indexi.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======================================================================= Csp.for 0100666 0000765 0000765 00000237550 11023416420 011570 0 ustar bulant bulant C
C Program SP (Seismogram Plotting) to plot seismograms previously stored C in the GSE data exchange format, and to plot travel-time curves. C C Version: 6.20 C Date: 2008, April 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 files: C SPPAR='string'... String with the name of an optional input SEP C parameter file. C If SPPAR is specified and its value is not blank, C program SP reads SEP parameter file SPPAR line by line C and updates the already read values of SEP parameters C with the values specified in file SPPAR. C When encountering string ' sp:' in file SPPAR, program SP C performs all actions as if it were executed. C In this way, parameter SPPAR enables multiple seismogram C plotting within a single execution of program SP. C This feature can speed-up plotting large number of field C seismograms. C Default: SPPAR=' ' 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 Hereinafter, # represents the value of integer constant MFILSS. C E.g., if MFILSS=12, SS# stands for SS12, KOLOR# stands for C KOLOR12, KOMP1# stands for KOMP112, etc. C SS1='string', SS2='string', ..., SS#='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. C The order of plottting is SS, SS1, SS2, ..., SS#, C considering just nonblank filenames. C The seismograms are plotted in colours given by parameters C KOLOR, KOLOR1, KOLOR2, ..., KOLOR#, respectively. C Refer to file C calcops.rgb C for the definitions of the colours. The frame and C description remain in colour number 1, which is probably C black. C Defaults: SS1=' ', SS2=' ', SS3=' ', ..., SS#=' ' 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 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 FTT='string'... String with the name of the optional input data C file 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 SPHILI='string'... String with the name of the optional input data C file 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 SPTTC='string'... String with the name of the optional input data C file, which specifies plotting of multiple travel-time C curves. C File SPTTC has the form of the SEP parameter file. C Each line of file SPTTC can change the values of C parameters FTT, SPHILI, KOLORTT, KOLORTD, SPSYMTT, SPSYMH, C SPHIWI. Each line of file SPTTC plots the data C contained in files FTT and SPHILI. C SPTTC=' ': The data contained in files FTT and SPHILI are C plotted only once. The same effect is achieved if file C SPTTC is specified but contains a single blank line. C Default: SPTTC=' ' 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, ..., KOMP1#=integer... C Components of the seismograms of files given by C parameters SS1, SS2, SS3, ..., SS#, respectively, C plotted into the output file given by parameter SP1. C Defaults: KOMP11=KOMP1, KOMP12=KOMP1, ..., KOMP1#=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, ..., KOMP2#=integer... C Analogous to KOMP11 to KOMP1#, 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, ..., KOMP3#=integer... C Analogous to KOMP11 to KOMP1#, but for file SP2. C Defaults equal the value of KOMP3. C Data to control plotting: C Colours and symbols: C KOLOR=positive integer, KOLOR1=positive integer, C KOLOR2=positive integer, ..., KOLOR#=positive integer... Colours C to plot seismograms of files SS,SS1, SS2, ..., SS#, 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 C calcops.rgb. C Default: KOLOR=1, KOLOR1=2, KOLOR2=3, ..., KOLOR#=#+1 C KOLORTT=integer... Colour to plot the travel times of optional C file FTT. It is also used as the default colour for C optional file SPHILI. C Travel times are not plotted if KOLORTT=0. C If KOLORTT is negative, travel times are plotted in colour C ABS(KOLORTT) and connected by a polyline. This option C may be useful only if the travel-time curve is C continuous and its points in file FTT or SPHILI are C carefully ordered. 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 ABS(KOLORTT). C Default: KOLORTD=0 C SPSYMTT=integer... Symbol to plot the travel times of optional C file FTT. It is also used as the default symbol for C optional file SPHILI. C SPSYMTT.LE.-1: Travel times are ploted as horizontal C lines of length given by parameter SPHIWI. C SPSYMTT.GE.0: Travel times are ploted by centred symbol C number SPSYMTT produced by CALCOMP subroutine SYMBOL. C The height of the centred symbol is determined by C parameter SPSYMH. C Default: SPSYMTT=-1 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, ..., SPXMIN#=real... C Analogous to SPXMIN, but for files SS1 to SS#. 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, ..., SPXMAX#=real... C Analogous to SPXMAX, but for files SS1 to SS#. 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, ..., SPYMIN#=real... C Analogous to SPYMIN, but for files SS1 to SS#. 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, ..., SPYMAX#=real... C Analogous to SPYMAX, but for files SS1 to SS#. 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, ..., SPAMP#=real... Amplitude scales C SPAMP individually set for optional input GSE files C given by parameters SS1, SS2, ..., SS#, respectively. C Defaults: SPAMP1=SPAMP, SPAMP2=SPAMP, ..., SPAMP#=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 SP2 (usually component C 2), by SPAMPX3 for file SP3 (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, ..., SPOWER#=real... Exponents of the C amplitude power scaling for optional input GSE files C given by parameters SS1, SS2, ..., SS#, respectively. C Defaults: SPOWER1=SPOWER, SPOWER2=SPOWER, ..., C SPOWER#=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, ..., SPEXP#=real... Exponential scaling C set individually for optional input GSE files given by C parameters SS1, SS2, ..., SS#, respectively. C Defaults: SPEXP1=SPEXP, SPEXP2=SPEXP, ..., SPEXP#=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 SPSYMH=real... Height in cm of centred symbols for plotting travel C times of files FTT or SPHILI. C Not used if SYMBOLTT is negative (default), or if neither C file FTT nor SPHILI is specified (default). C If SPSYMH.LT.0., the height of centred symbols corresponds C to the doubled error of the plotted travel time. C You may wish to put SPSYMH=0 if you have selected negative C KOLORTT. C Default: SPSYMH=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 CALCOPS='string'... String with the PostScript instructions, see C file C calcops.for. 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 C 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,K3,/ 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 K3... Integer specifying the symbol to plot the travel time. C K3.LE.-1: Travel times are ploted as horizontal lines C of length given by parameter SPHIWI. C K3.GE.0: Travel times are ploted by centred symbol C number SPSYMTT produced by CALCOMP subroutine SYMBOL. C The height of the centred symbol is determined by C parameter SPSYMH. C Default: X1REC(IR)=0, X2REC(IR)=0, X3REC(IR)=0., K1=KOLORTT, C K2=KOLORTD, K3=SPSYMTT 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,UARRAY REAL UARRAY INTEGER LENGTH EXTERNAL STRIND C The length of character function STRIND is declared later on. C C Input and output data filenames and logical unit numbers: INTEGER LU,LUPAR,LUTTC,MFILSS,MDIGSS PARAMETER (LU=1,LUPAR=2,LUTTC=3,MFILSS=29,MDIGSS=2) C MFILSS..Maximum number of input files with synthetic seismograms. C MDIGSS..Number of digits of MFILSS. CHARACTER*80 FILSEP,FILPAR,FILPTS,FILSRC,FILREC,FILFTT,FILHIL CHARACTER*80 FILTTC CHARACTER*80 FILOLD(0:MFILSS),FILESS(0:MFILSS),FILEPS(3) C C Storing seismograms in memory INTEGER IFILO(0:MFILSS),IFILE(0:MFILSS),ISSRAM(0:MFILSS+1) 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 INTEGER KOLOR(0:MFILSS),KOMP(0:MFILSS,3) INTEGER ISS,ISP REAL SPXMIN(0:MFILSS),SPXMAX(0:MFILSS) REAL SPYMIN(0:MFILSS),SPYMAX(0:MFILSS) REAL SPAMP(0:MFILSS,3),SPOWER(0:MFILSS),SPEXP(0:MFILSS) REAL SPAMPX(3),XPTS(4),YPTS(4) C CHARACTER*(6+MDIGSS) STRIND CHARACTER*5 STRKOM 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 Indices of the sets of SEP parameters INTEGER ISEP,IOLD 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 INTEGER MFILS1 PARAMETER (MFILS1=MFILSS+1) DATA FILESS/MFILS1*' '/ DATA KXTEXT/' ','X1','X1','X3','HYPOCENTRAL DISTANCE'/ C UNDEF=UARRAY() 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 Defining index ISEP of the working set of SEP parameters: ISEP=0 CALL SSEP(ISEP,IOLD) CALL SSEP(IOLD,ISEP) 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,MFILSS 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') DO 112 I1=1,MFILSS CALL RSEP3T(STRIND('SS',I1),FILESS(I1),' ') 112 CONTINUE CALL RSEP3T('SP1',FILEPS(1),'ss1.ps') CALL RSEP3T('SP2',FILEPS(2),'ss2.ps') CALL RSEP3T('SP3',FILEPS(3),'ss3.ps') IF(FILPAR.EQ.' ') THEN ISS0=0 ELSE DO 129 I2=0,MFILSS IF(FILOLD(I2).NE.' ') THEN DO 121 I1=0,MFILSS 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,MFILSS 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,MFILSS IF(FILESS(I2).NE.' ') THEN DO 131 I1=0,MFILSS 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 ISEP=-ISEP CALL SSEP(ISEP,IOLD) 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 SSEP(IOLD,ISEP) 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: DO 152 I2=1,3 STRKOM=STRIND('KOMP',I2) CALL RSEP3I(STRKOM,KOMP(0,I2),I2) DO 151 I1=1,MFILSS CALL RSEP3I(STRIND(STRKOM,I1),KOMP(I1,I2),KOMP(0,I2)) 151 CONTINUE 152 CONTINUE C C Colours: CALL RSEP3I('KOLOR ',KOLOR(0),1) DO 153 I1=1,MFILSS CALL RSEP3I(STRIND('KOLOR',I1),KOLOR(I1),I1+1) 153 CONTINUE 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.) DO 154 I1=1,MFILSS CALL RSEP3R(STRIND('SPXMIN',I1),SPXMIN(I1),SPXMIN(0)) 154 CONTINUE CALL RSEP3R('SPXMAX ',SPXMAX(0),RECNUM+1.) DO 155 I1=1,MFILSS CALL RSEP3R(STRIND('SPXMAX',I1),SPXMAX(I1),SPXMAX(0)) 155 CONTINUE CALL RSEP3R('SPYMIN ',SPYMIN(0), 0.) DO 156 I1=1,MFILSS CALL RSEP3R(STRIND('SPYMIN',I1),SPYMIN(I1),SPYMIN(0)) 156 CONTINUE CALL RSEP3R('SPYMAX ',SPYMAX(0), 0.) DO 157 I1=1,MFILSS CALL RSEP3R(STRIND('SPYMAX',I1),SPYMAX(I1),SPYMAX(0)) 157 CONTINUE 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.) DO 161 I1=1,MFILSS CALL RSEP3R(STRIND('SPAMP',I1),SPAMP(I1,1),SPAMP(0,1)) 161 CONTINUE CALL RSEP3R('SPAMPX1',SPAMPX(1),1.) CALL RSEP3R('SPAMPX2',SPAMPX(2),1.) CALL RSEP3R('SPAMPX3',SPAMPX(3),1.) DO 168 I2=3,1,-1 DO 167 I1=0,MFILSS SPAMP(I1,I2)=SPAMP(I1,1)*SPAMPX(I2) 167 CONTINUE 168 CONTINUE CALL RSEP3R('SPDIST' ,SPDIST,1.) CALL RSEP3R('SPOWER' ,SPOWER(0),0.) DO 164 I1=1,MFILSS CALL RSEP3R(STRIND('SPOWER',I1),SPOWER(I1),SPOWER(0)) 164 CONTINUE CALL RSEP3R('SPEXP ',SPEXP(0),0.) DO 165 I1=1,MFILSS CALL RSEP3R(STRIND('SPEXP',I1),SPEXP(I1),SPEXP(0)) 165 CONTINUE 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....................................................................... 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 Multiple trave-time curves: CALL RSEP3T('SPTTC',FILTTC,' ') IF(FILTTC.NE.' ') THEN OPEN(LUTTC,FILE=FILTTC,STATUS='OLD') END IF C C Loop over individual trave-time curves: 200 CONTINUE IF(FILTTC.NE.' ') THEN C Loop over lines the SP parameter file READ(LUTTC,'(A)',END=300) LINE CALL RSEP2(LINE) END IF C C Higlighting given areas (e.g., travel times with error bars): CALL RSEP3T('FTT' ,FILFTT,' ') CALL RSEP3T('SPHILI' ,FILHIL,' ') CALL RSEP3I('KOLORTT',KOLORT,1) CALL RSEP3I('KOLORTD',KOLORD,0) CALL RSEP3I('SPSYMTT',KSYMTT,-1) CALL RSEP3R('SPSYMH' ,SPSYMH,0.4) CALL RSEP3R('SPHIWI' ,SPHIWI,SPXLEN/(RECNUM+1.)) C C Higlighting travel times of file FTT: IF(FILFTT.NE.' ') THEN XOLD=UNDEF 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: C Highlighting travel-time error bar IF(KOLORD.GE.0) THEN IF(T0+TD.GT.SSTMIN) THEN IF(T0-TD.LT.SSTMAX) 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*(AMAX1(T0-TD,SSTMIN)-SPTMIN) YPTS(2)=YPTS(1) YPTS(3)=SCY*(AMIN1(T0+TD,SSTMAX)-SPTMIN) YPTS(4)=YPTS(3) IF(KOLORD.GT.0) THEN CALL NEWPEN(KOLORD) CALL FILL(XPTS,YPTS,4) ELSE IF(KOLORT.NE.0) THEN CALL NEWPEN(IABS(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 END IF END IF C Plotting travel time IF(KOLORT.NE.0) THEN IF(SSTMIN.LT.T0.AND.T0.LT.SSTMAX) THEN CALL NEWPEN(IABS(KOLORT)) IF(KOLORT.LT.0) THEN IF(XOLD.NE.UNDEF) THEN CALL PLOT(XOLD,YOLD,3) CALL PLOT(X,SCY*(T0-SPTMIN),2) END IF XOLD=X YOLD=SCY*(T0-SPTMIN) END IF IF(KSYMTT.LT.0) THEN CALL PLOT(X-0.5*SPHIWI,SCY*(T0-SPTMIN),3) CALL PLOT(X+0.5*SPHIWI,SCY*(T0-SPTMIN),2) ELSE IF(SPSYMH.NE.0.) THEN IF(SPSYMH.GT.0.) THEN H=SPSYMH ELSE H=SCY*2.*TD END IF CALL SYMBOL(X,SCY*(T0-SPTMIN),H,CHAR(KSYMTT),0.,-1) END IF END IF 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 XOLD=UNDEF 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 K3=KSYMTT READ(LU,*,END=39) NAMREC,X1R,X2R,X3R,T0,TD,K1,K2,K3 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=0 K2=-1 END IF IF(TD.EQ.UNDEF) THEN K2=-1 END IF C Highlighting travel-time error bar IF(K2.GE.0) THEN IF(T0+TD.GT.SSTMIN) THEN IF(T0-TD.LT.SSTMAX) 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*(AMAX1(T0-TD,SSTMIN)-SPTMIN) YPTS(2)=YPTS(1) YPTS(3)=SCY*(AMIN1(T0+TD,SSTMAX)-SPTMIN) YPTS(4)=YPTS(3) IF(K2.GT.0) THEN CALL NEWPEN(K2) CALL FILL(XPTS,YPTS,4) ELSE IF(K1.NE.0) THEN CALL NEWPEN(IABS(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) CALL PLOT(XPTS(1),YPTS(1),2) END IF END IF END IF END IF C Plotting travel time IF(K1.NE.0) THEN IF(SSTMIN.LT.T0.AND.T0.LT.SSTMAX) THEN CALL NEWPEN(IABS(K1)) IF(K1.LT.0) THEN IF(XOLD.NE.UNDEF) THEN CALL PLOT(XOLD,YOLD,3) CALL PLOT(X,SCY*(T0-SPTMIN),2) END IF XOLD=X YOLD=SCY*(T0-SPTMIN) END IF IF(K3.LT.0) THEN CALL PLOT(X-0.5*SPHIWI,SCY*(T0-SPTMIN),3) CALL PLOT(X+0.5*SPHIWI,SCY*(T0-SPTMIN),2) ELSE IF(SPSYMH.GT.0.) THEN H=SPSYMH ELSE H=SCY*2.*TD END IF CALL SYMBOL(X,SCY*(T0-SPTMIN),H,CHAR(K3),0.,-1) END IF END IF END IF GO TO 30 39 CONTINUE C Closing highlighting file CLOSE(LU) END IF C IF(FILTTC.NE.' ') THEN GO TO 200 END IF 300 CONTINUE IF(FILTTC.NE.' ') THEN CLOSE(LUTTC) END IF C End of the loop over individual trave-time curves C C Plotting seismograms: C Loop for GSE files DO 90 ISS=0,MFILSS IF(FILESS(ISS).NE.' ') THEN CALL NEWPEN(KOLOR(ISS)) XA=SPXMAX(ISS)-SPXMIN(ISS) YA=SPYMAX(ISS)-SPYMIN(ISS) 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 Loop for seismograms IREC=0 40 CONTINUE 41 CONTINUE 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 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 Reading the source information: IF(FILPAR.EQ.' ') THEN ISEP=-ISEP CALL SSEP(ISEP,IOLD) 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.) CALL SSEP(IOLD,ISEP) END IF 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 Closing GSE file IF(FILPAR.EQ.' ') THEN CLOSE(LU) END IF END IF 90 CONTINUE C End of loop for GSE files 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 'forms.for' C forms.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 00000107107 11023416420 012457 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: 6.00 C Date: 2006, June 15 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....................................................................... 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 C 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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 00000020525 11023416420 011742 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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 00000136377 11023416420 011600 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: 6.20 C Date: 2007, September 29 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. C Since the source time function is defined here as the time C dependence of the far-field displacement, the reponse C function corresponds to the Dirac time dependence of the C seismic force at a point source, but to the Heavyside time C dependence of the seismic moment at a point source. C The file is generated by program 'greenss.for'. C The file is not used if SS=' '. 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 C '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 C '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 Here the "source time function" represents the time dependence of C the far-field displacement. For example, at a point source, the C source time function represents the time dependence of the seismic C force, but the derivative of the time dependence of the seismic C moment. If you specify the time dependence of the seismic moment C at a point source, you should enter DER=1 to obtain the time C dependence of the far-field displacement. If you specify the C time dependence of the seismic moment at a line source, you should C enter DER=0.5 to obtain the time dependence of the far-field C displacement. If you specify the time dependence of the seismic C force at a line source, you should enter DER=-0.5 to obtain the C time dependence of the far-field displacement. 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 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: Ricker signal (according to Sheriff: Encyclopedic C Dictionary of Applied Geophysics) C f(t)=(1-2*A*t'*t')*exp(-A*t'*t') C where A=pi*pi*SIGF*SIGF and t'=t-SIGT-0.5/SIGF. C KSIG=7: 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 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 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 CALCOPS='string'... String with the PostScript instructions, see C file C calcops.for. 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 C 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 REAL UARRAY EXTERNAL UARRAY 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 INTEGER LU4,LU5,LU6,LU7 PARAMETER (LU4=1,LU5=2,LU6=3,LU7=4) C INTEGER KSGNL,MPTS,NPTS,KPTS,N,I,N1,N2,J,K,NF,NF1,NF2,IREC,NUMS, * MINIM,MAXIM REAL UNDEF,PSGNL(10),DER,HILB,DT,FMIN,FR,FMAX,FL,SIGT,TRED,VRED, * A,F,FD,FDA,C,S,FMINIM,X,Y,Z,TMIN,TMAX,AMAX,B,T0 CHARACTER*80 TEXT1 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 UNDEF=UARRAY() 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) INTEGER NPTS,KSGNL REAL S(2,NPTS),PAR(*),SIGT,DT C EXTERNAL ERROR REAL T,A,B,C,D,E,F,TMAX,TRED INTEGER I,N1,N2 C GO TO (10,20,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 Ricker signal (according to Sheriff: Encyclopedic C Dictionary of Applied Geophysics) 20 CONTINUE T= -DT*FLOAT(NPTS/2) SIGT= SIGT+T+1./PAR(1)/2. C SIGT= SIGT+T A= 3.141593*3.141593*PAR(1)*PAR(1) DO 21 I=1,NPTS S(1,I)=0. S(1,I)= (1.-2*A*T*T)*EXP(-A*T*T) T = T+DT 21 CONTINUE RETURN C C Ricker signal (according to specification in this code) C 20 CONTINUE C T = -DT*FLOAT(NPTS/2) C SIGT= SIGT+T C A = PAR(1)*PAR(1) C DO 21 I=1,NPTS C S(1,I)=0. C S(1,I)= -1.*PAR4*(2*A*T*T-1)*EXP(-A*T*T) C T = T+DT C 21 CONTINUE C 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) INTEGER KPLOT,NUMS,NUM,MPTS,NPTS,N1,N2 REAL S(2,NPTS),TL,DT,AMP CHARACTER*(*) FILPS C EXTERNAL ERROR,PLTIM,PLOTN,PLOT,NUMBER INTEGER LU6,I,N3,N4,NUM1 REAL EPS,SMALL,T1,T2,T3,T4,A,X,Y 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 REAL T,T3,T4,B EXTERNAL PLOT,NUMBER REAL A 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 REAL D,SN,SH,FNW,AA,W1,W2,Q1,Q2 INTEGER INU,I,IL,K,NKK,NCK,LCK,L2K,LX,LA,LS,NW,ICK,J,J1,JH,JH1,ID, * JJ 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 'forms.for' C forms.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 00000011540 11023416420 012105 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 00000050216 11023416420 012106 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 00000035020 11023416420 012776 0 ustar bulant bulant C
C Program TRGLNORM to compute normals to given triangles C C Version: 6.00 C Date: 2005, November 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 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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. C For the value of UNDEF see function UARRAY of file C forms.for. 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,UARRAY REAL UARRAY 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 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 UNDEF=UARRAY() 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 00000066016 11023416420 012456 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 C 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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 C error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... File C sep.for. C FORM1,LOWER ... File C forms.for. C LENGTH ... File C length.for. C COLOR1,COLOR2,COLOR3 ... File C 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 00000036214 11023416420 013020 0 ustar bulant bulant C
C Program TRGLSORT to sort triangles according to values at its vertices C C Version: 6.00 C Date: 2005, November 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 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 function UARRAY of file C forms.for. 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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,UARRAY REAL UARRAY INTEGER LENGTH C C....................................................................... C C Auxiliary storage locations: INTEGER LU,IUNDEF,NOUT PARAMETER (LU=1,IUNDEF=-999999,NOUT=3) REAL UNDEF 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 UNDEF=UARRAY() 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 00000013721 11024140020 012452 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: 6.20 C Date: 2008, June 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 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 matrix header files: C SM1='string' ... Name of the header file of the input symmetric C matrix SM1. C No default, SM1 must be specified and cannot be blank. C SM2='string'... Name of the header file of the input symmetric C matrix SM2. C No default, SM2 must be specified and cannot be blank. C TRACE='string'... Name of the header file of the output C general matrix containing a single value, trace C tr(SM1*SM2) of the product of two symmetric matrices C SM1 and SM2. C No default, TRACE must be specified and cannot be blank. C Recent version of the program cannot deal with sparse matrices. C For general description of the files with matrices refer to file C forms.htm. C Form of the output file with matrix TRACE: C FORMM='string' ... Form of the output files with matrices. Allowed C values are FORMM='formatted' and FORMM='unformatted'. C C----------------------------------------------------------------------- C C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RMAT,WMAT C ERROR ... File error.for. C RSEP1,RSEP3T ... File C sep.for. C RMAT,WMAT ... File mat.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 INCLUDE 'mat.for' C mat.for C C======================================================================= Ctsurf.for 0100666 0000765 0000765 00000020342 11023416420 012276 0 ustar bulant bulant C
C Program TSURF to convert GOCAD triangulated surfaces into a file with C points and a file with triangles C C Version: 5.90 C Date: 2004, 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 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 Optional parameters specifying the form of the real quantities C written in the output formatted files: C MINDIG,MAXDIG=positive integers ... See the description in file C forms.for. 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 00000016306 11023416420 011744 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' C has not been specified 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' C 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 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 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