auxmod.inc 0100666 0000765 0000765 00000002553 06355637664 012452 0 ustar bulant bulant C
C Auxiliary storage locations for local model parameters: FAUX(10), C G(12),GAMMA(18),GSQRD, UP(10),US(10),RO,QP,QS, VP,VS,VD(10),QL: C C INCLUDE 'auxmod.inc' C ------------------------------------------------------------------ REAL G(12),GAMMA(18),GSQRD,FAUX(10) REAL UP(10),US(10),RO,QP,QS,VP,VS,VD(10),QL COMMON/AUXMOD/ G,GAMMA,GSQRD,FAUX,UP,US,RO,QP,QS,VP,VS,VD,QL C ------------------------------------------------------------------ C G,GAMMA,GSQRD... See subroutine METRIC of the file 'metric.for'. C FAUX... Auxiliary array to store a functional value and its C derivatives. C UP,US,RO,QP,QS... See subroutine PARM2 of the file 'parm.for'. C UP,US,QP,QS,VP,VS,VD,QL... See subroutine VELOC of the file C 'model.for'. C C These auxiliary variables and arrays need not be located in a C common block. There is no reason to locate them in the auxiliary C common block /AUXMOD/ but to share the memory. C C Common block /AUXMOD/ may utilized in any subroutine calling C subroutines METRIC, SURF2, PARM2 or VELOC. C C Date: 1996, July 8 C Coded by Ludek Klimes C C======================================================================= Cbndlin.for 0100666 0000765 0000765 00000013374 07106173130 012415 0 ustar bulant bulant C
C Program BNDLIN to write 12 lines forming edges of the model box C C Version: 5.40 C Date: 2000, 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 Data specifying the input model file: C MODEL='string'... Input data file describing the model. C Description of file MODEL C Default: 'MODEL'='model.dat' C Data specifying the output file: C LIN='string'... Name of the output file. It is recommended to C specify it rather than to use the default name. C Format of file LIN C Default: LIN='lin.out' C C======================================================================= C C Common block /MODELC/: INCLUDE 'model.inc' C None of the storage locations of the common block are altered. C C----------------------------------------------------------------------- C CHARACTER*80 FILE1 PARAMETER (LU1=1) C C Reading main input data: WRITE(*,'(A)') '+BNDLIN: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF(FILE1.EQ.' ') THEN C BNDLIN-01 CALL ERROR('BNDLIN-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)') '+BNDLIN: Working... ' CALL RSEP1(LU1,FILE1) C C Reading the model description file: CALL RSEP3T('MODEL',FILE1,'model.dat') OPEN(LU1,FILE=FILE1,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) C C Step along the lines (presently non-documented feature) CALL RSEP3R('BNDSTEP',STEP,999999.) C C Reading output filename and opening the output file: CALL RSEP3T('LIN',FILE1,'lin.out') OPEN(LU1,FILE=FILE1) C WRITE(LU1,'(A)') '/' CALL WLINE(LU1,BOUNDM(1),BOUNDM(3),BOUNDM(5), * BOUNDM(2),BOUNDM(3),BOUNDM(5),STEP) CALL WLINE(LU1,BOUNDM(2),BOUNDM(3),BOUNDM(5), * BOUNDM(2),BOUNDM(4),BOUNDM(5),STEP) CALL WLINE(LU1,BOUNDM(2),BOUNDM(4),BOUNDM(5), * BOUNDM(1),BOUNDM(4),BOUNDM(5),STEP) CALL WLINE(LU1,BOUNDM(1),BOUNDM(4),BOUNDM(5), * BOUNDM(1),BOUNDM(3),BOUNDM(5),STEP) CALL WLINE(LU1,BOUNDM(1),BOUNDM(3),BOUNDM(6), * BOUNDM(2),BOUNDM(3),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(2),BOUNDM(3),BOUNDM(6), * BOUNDM(2),BOUNDM(4),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(2),BOUNDM(4),BOUNDM(6), * BOUNDM(1),BOUNDM(4),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(1),BOUNDM(4),BOUNDM(6), * BOUNDM(1),BOUNDM(3),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(1),BOUNDM(3),BOUNDM(5), * BOUNDM(1),BOUNDM(3),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(2),BOUNDM(3),BOUNDM(5), * BOUNDM(2),BOUNDM(3),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(2),BOUNDM(4),BOUNDM(5), * BOUNDM(2),BOUNDM(4),BOUNDM(6),STEP) CALL WLINE(LU1,BOUNDM(1),BOUNDM(4),BOUNDM(5), * BOUNDM(1),BOUNDM(4),BOUNDM(6),STEP) WRITE(LU1,'(A)') '/' CLOSE(LU1) WRITE(*,'(A)') '+BNDLIN: Done. ' STOP END C C======================================================================= C SUBROUTINE WLINE(LU1,X1,X2,X3,Y1,Y2,Y3,STEP) C WRITE(LU1,'(A)') '''MODEL BOUNDARY''' WRITE(LU1,'(A)') '/' DIST=SQRT((X1-Y1)**2+(X2-Y2)**2+(X3-Y3)**2) DO 10 S=0.,0.999999,STEP/AMAX1(DIST,STEP) Z=AMIN1(S+STEP/AMAX1(DIST,STEP),1.) S1=X1+(Y1-X1)*S S2=X2+(Y2-X2)*S S3=X3+(Y3-X3)*S Z1=X1+(Y1-X1)*Z Z2=X2+(Y2-X2)*Z Z3=X3+(Y3-X3)*Z WRITE(LU1,'(3(G12.6,X),A)') S1,S2,S3,' /' WRITE(LU1,'(3(G12.6,X),A)') Z1,Z2,Z3,' /' WRITE(LU1,'(A)') '/' 10 CONTINUE RETURN END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for INCLUDE 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for C C======================================================================= Cclean.for 0100666 0000765 0000765 00000007174 06601110270 012225 0 ustar bulant bulant C
C Program 'CLEAN' to modify lines with a given character in the first C column. C C Date: 1998, September 20 C Coded by Ludek Klimes C C....................................................................... C C This program is designed to edit FORTRAN77 source code files C containing other characters than 'C' or '*' in the first column. Such C source files may be created with the intention of a conditioned C compilation not enabled by the FORTRAN77 standard. C C....................................................................... C C C Description of the data files: 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','COLD','CNEW',/ C 'FOLD'..Name of the input file. C 'FNEW'..Name of the output file. C 'COLD'..Characters in the first 2 columns of some lines of C 'FOLD' to be replaced. C 'CNEW'..New pair of characters replacing 'COLD'. If 'CNEW'='- ', C the whole line is deleted. C /... An obligatory slash for the sake of compatibility with C future extensions. C C----------------------------------------------------------------------- C CHARACTER*80 FOLD,FNEW CHARACTER*2 COLD,CNEW CHARACTER*72 LINE INTEGER IERR,I,J,K C WRITE(*,'(2A)') '+Enter old and new filenames, ', * 'and old and new strings in the first 2 columns: ' READ(*,*) FOLD,FNEW,COLD,CNEW 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 CLEAN-01 CALL ERROR * ('CLEAN-01: Input FORTRAN77 source file does not exist') END IF C- OPEN(2,FILE=FNEW,STATUS='NEW',IOSTAT=IERR) C- IF(IERR.NE.0) THEN C- CLEAN-02 C- CALL ERROR C- * ('CLEAN-02: Output FORTRAN77 source file already exists') C- END IF OPEN(2,FILE=FNEW) C C Loop for the lines in the input source file WRITE(*,'(2A)') '+Editing ',FNEW(1:70) 20 CONTINUE C C Reading a line: READ(1,'(A)',END=90) LINE C C Copying a line: IF(LINE(1:2).EQ.COLD) THEN LINE(1:2)=CNEW END IF IF(LINE(1:2).NE.'- ') THEN 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 WRITE(2,'(A)') LINE(1:I) GO TO 20 END IF 31 CONTINUE END IF 32 CONTINUE END IF 33 CONTINUE C Empty line: WRITE(*,'(2A)') '+Warning: Empty line in ',FOLD(1:56) WRITE(*,'(A)') ' ' END IF 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======================================================================= Cfit.for 0100666 0000765 0000765 00000147275 06621475602 011753 0 ustar bulant bulant C
C Subroutines of the software package 'FITPACK' by A.K. Cline C used to specify the model for the complete ray tracing algorithm. C C This file consists of the following parts: C (0) Auxiliary subroutine C SNHCSH C SNHCSH C common to all the following parts. C (1) The subroutines preparing the parameters necessary to compute C an interpolatory function: C CURVN1 (Hermite representation of 1-D function), C CURVB1 (B-spline representation of 1-D function), C SURFB1 (B-spline representation of 2-D function), C VAL3B1 (B-spline representation of 3-D function), C VGEN (auxiliary subroutine), C TERMS (auxiliary subroutine), C TRIDEC (auxiliary subroutine), C TRISOL (auxiliary subroutine). C CURVN1 C CURVB1 C SURFB1 C VAL3B1 C VGEN C TERMS C TRIDEC C TRISOL C Subroutines CURVN1 and CURVB1 are alternatives. C (2) The subroutines evaluating the value, first and second partial C derivatives of the interpolatory function at a given point: C CURV2D (Hermite representation of 1-D function), C CURVBD (B-spline representation of 1-D function), C SURFBD (B-spline representation of 2-D function), C VAL3BD (B-spline representation of 3-D function), C DSPLNZ (auxiliary subroutine), C INTRVL (auxiliary external function). C CURV2D C CURVBD C SURFBD C VAL3BD C DSPLNZ C INTRVL C Subroutines CURV2D and CURVBD are alternatives. C C Taken from: C FITPACK - A Software Package for Curve and Surface Fitting C Employing Splines under Tension C by Alan Kaylor Cline, Department of Computer Sciences, C The University of Texas at Austin, August 31, 1981. C Note 1: C To conform with the FORTRAN77 standard, dummy array dimensions (1) C have been changed to (*), and subroutine TRISOL has been revised. C Note 2: C Subroutines CURVB1 and CURVBD do not belong to the original C version of FITPACK. C Note 3 C The lines denoted by '*V' in the first two columns of file C 'fit.for' calculate the model variations with respect to the model C parameters. C File 'fitv.for', intended for the model inversion, is created C from 'fit.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C Note 4: C To get the original versions of the subroutines SURFBD and VAL3BD, C the statement with 'CALL VAR2' must be removed from each of them. C The statements have been added by L.Klimes for the sake of inverse C modelling to the subroutines CURVBD, SURFBD, and VAL3BD. C The three appearances of the statements 'CALL VAR2' are denoted by C '*V' in the first 2 columns. The three lines should be removed or C modified before compilation. C C======================================================================= C C Part 0: C C======================================================================= C C C SUBROUTINE SNHCSH (SINHM,COSHM,X,ISW) C INTEGER ISW REAL SINHM,COSHM,X C C From FITPACK -- August 31, 1981 C Coded by A. K. Cline and R. J. Renka C Department of Computer Sciences C University of Texas at Austin C C This subroutine returns approximations to C SINHM(X) = SINH(X)-X C COSHM(X) = COSH(X)-1 C and C COSHMM(X) = COSH(X)-1-X*X/2 C with relative error less than 6.16e-6 C C On input-- C C X contains the value of the independent variable. C C ISW indicates the function desired C = -1 if only SINHM is desired, C = 0 if both SINHM and coshm are desired, C = 1 if only COSHM is desired, C = 2 if only COSHMM is desired, C = 3 if both SINHM and COSHMM are desired. C C On output-- C C SINHM contains the value of SINHM(X) if ISW .LE. 0 or C ISW .EQ. 3 (SINHM is unaltered if ISW .EQ.1 or ISW .EQ. C 2). C C COSHM contains the value of COSHM(X) if ISW .EQ. 0 or C ISW .EQ. 1 and contains the value of COSHMM(X) if ISW C .GE. 2 (COSHM is unaltered if ISW .EQ. -1). C C And C C X and ISW are unaltered. C C----------------------------------------------------------- C DATA SP2/5.04850926418006E-04/, * SP1/3.62841692246321E-02/, * SQ1/-1.37157937097122E-02/ DATA CP2/1.31625490355985E-03/, * CP1/6.57866547762733E-02/, * CQ1/-1.75465241841312E-02/ DATA ZP2/1.40048186158693E-04/, * ZP1/1.67309141907440E-02/, * ZQ2/9.82154460147143E-05/, * ZQ1/-1.66024148976133E-02/ XX = X AX = ABS(XX) XS = XX*XX IF ((AX .GE. 2.20) .OR. (AX .GE. 1.17 .AND. * ISW .NE. 2)) EXPX = EXP(AX) C C SINHM approximation C IF (ISW .EQ. 1 .OR. ISW .EQ. 2) GO TO 2 IF (AX .GE. 1.17) GO TO 1 SINHM = (((SP2*XS+SP1)*XS+1.)*XS*XX)/((SQ1*XS+1.)*6.) GO TO 2 1 SINHM = (EXPX-1./EXPX)/2.-AX IF (XX .LT. 0.) SINHM = -SINHM C C COSHM approximation C 2 IF (ISW .NE. 0 .AND. ISW .NE. 1) GO TO 4 IF (AX .GE. 1.17) GO TO 3 COSHM = (((CP2*XS+CP1)*XS+1.)*XS)/((CQ1*XS+1.)*2.) GO TO 4 3 COSHM = (EXPX+1./EXPX)/2.-1. C C COSHMM approximation C 4 IF (ISW .LE. 1) RETURN IF (AX .GE. 2.20) GO TO 5 COSHM = (((ZP2*XS+ZP1)*XS+1.)*XS*XS)/(((ZQ2*XS+ZQ1)*XS * +1.)*24.) RETURN 5 COSHM = (EXPX+1./EXPX)/2.-1.-XS/2. RETURN END C C======================================================================= C C Part 1: C C======================================================================= C C C SUBROUTINE CURVN1 (N,X,Y,YP,TEMP,SIGMA,IERR) C INTEGER N,IERR REAL X(N),Y(N),YP(N),TEMP(N),SIGMA C C From FITPACK -- August 31, 1981 C Coded by a. K. Cline and s. E. Galinsky C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines the parameters necessary to C compute a natural interpolatory spline under tension C through a sequence of functional values. For actual C computation of points on the curve it is necessary to call C the function CURV2. C C On input-- C C N is the number of values to be interpolated (N.GE.2). C C X is an array of the N increasing abscissae of the C functional values. C C Y is an array of the N ordinates of the values, (i. e. C Y(K) is the functional value corresponding to X(K) ). C C YP is an array of length at least N. C C TEMP is an array of length at least N which is used for C scratch storage. C C And C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e.g. .001) the resulting curve is approximately a C cubic spline. If ABS(SIGMA) is large (e.g. 50.) the C resulting curve is nearly a polygonal line. If SIGMA C equals zero a cubic spline results. A standard value C for SIGMA is approximately 1. In absolute value. C C On output-- C C YP contains the values of the second derivative of the C curve at the given nodes. C C IERR contains an error flag, C = 0 for normal return, C = 1 if N is less than 2, C = 2 if X-values are not strictly increasing. C C And C C N, X, Y, and SIGMA are unaltered. C C This subroutine references package modules SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 NP1 = N+1 IERR = 0 IF (N .LE. 1) GO TO 4 IF (X(N) .LE. X(1)) GO TO 5 C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Set up right hand side and tridiagonal system for YP and C perform forward elimination C DELX1 = X(2)-X(1) IF (DELX1 .LE. 0.) GO TO 5 DX1 = (Y(2)-Y(1))/DELX1 CALL TERMS (DIAG1,SDIAG1,SIGMAP,DELX1) SDIAG1 = 0. YP(1) = 0. TEMP(1) = 0. IF (N .EQ. 2) GO TO 2 DO 1 I = 2,NM1 DELX2 = X(I+1)-X(I) IF (DELX2 .LE. 0.) GO TO 5 DX2 = (Y(I+1)-Y(I))/DELX2 CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELX2) DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1) YP(I) = (DX2-DX1-SDIAG1*YP(I-1))/DIAG TEMP(I) = SDIAG2/DIAG DX1 = DX2 DIAG1 = DIAG2 1 SDIAG1 = SDIAG2 2 YP(N) = 0. TEMP(N-1) = 0. C C Perform back substitution C DO 3 I = 2,N IBAK = NP1-I 3 YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) RETURN C C Too few points C 4 IERR = 1 RETURN C C X-values not strictly increasing C 5 IERR = 2 RETURN END C C======================================================================= C C C SUBROUTINE CURVB1 (NX,X,W,C,VX,TEMP,SIGMA,IERR) C INTEGER NX,IERR REAL X(NX),W(NX),C(NX),VX(5,NX),TEMP(*),SIGMA C C Complement to FITPACK C by Alan Kaylor Cline C Coded -- October 9, 1986 C by Ludek Klimes C Inst. Geol. Geotechn. C Czechosl. Acad. Sci., Prague C C This subroutine determines the parameters necessary to C compute an interpolatory function on a one dimensional C grid. The function determined can be C represented by splines under tension. For actual C mapping of points it is necessary to call the subroutine C CURVBD, which also returns first and second derivatives. C C On input-- C C NX is the number of grid points. C (NX should be at least 2) C C X is array of the NX coordinates of the grid points. C These should be strictly increasing. C C W is an array of the NX functional values at the C the grid points, i. e. W(I,J) contains the functional C value at X(I) for I = 1,...,NX . C C C is an array of at least NX locations. This C parameter may coincide with W in which case W is C destroyed on output. C C VX is the array of at least 5 * NX locations. C C TEMP is an array of at least 3 * NX locations C which is used for scratch storage. C C SIGMA contains the tension factor. This value indicate C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the resulting surface is approximately the C tensor product of cubic splines. If ABS(SIGMA) is large C (e. g. 50.) the resulting surface is approximately C bi-linear. If SIGMA equals zero tensor products of cubic C splines result. A standard value for SIGMA is C approximately 1. In absolute value. C C On output-- C C C contains the coefficients of a representation of the C interpolated function in a B-spline form. C C VX contains B-spline under tension basis data. C C IERR contains an error flag. C = 0 for normal return, C = 1 if NX is less than 2, C = 2 if the X-array is not strictly C increasing. C C And C C None of the input parameters are altered (except W if C this parameter and C are identical in the calling C sequence). C C This subroutine references package modules VGEN, TERMS, C SNHCSH, TRIDEC, and TRISOL. C C----------------------------------------------------------- C C Copy W into C C DO 1 I = 1,NX 1 C(I) = W(I) C C Generate basis functions along X-grid C set up tridiagonal system and solve C CALL VGEN (NX,X,SIGMA,VX,IERR) IF (IERR .NE. 0) RETURN DO 2 I = 2,NX 2 TEMP(I) = VX(5,I-1) NXPI = NX DO 3 I = 1,NX NXPI = NXPI+1 3 TEMP(NXPI) = 1. DO 4 I = 2,NX NXPI = NXPI+1 4 TEMP(NXPI) = VX(4,I) CALL TRIDEC (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1), * TEMP(1),TEMP(NX+1),IERR) CALL TRISOL (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1),C,NX, * 1,1) RETURN END C C======================================================================= C C C SUBROUTINE SURFB1 (NX,NY,X,Y,W,NW1,C,VX,VY,TEMP,SIGMA, * IERR) C INTEGER NX,NY,NW1,IERR REAL X(NX),Y(NY),W(NW1,NY),C(NX,NY),VX(5,NX),VY(5,NY), * TEMP(*),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines the parameters necessary to C compute an interpolatory function on a two dimensional C rectangular grid. The function determined can be C represented as a tensor product of splines under tension C for actual mapping of points it is necessary to call the C subroutine SURFBD, which also returns first and second C partial derivatives. C C On input-- C C NX and NY are the number of grid lines in the X- and Y C directions, respectively, of the rectangular grid. (NX C and NY should be at least 2.) C C X and Y are arrays of the NX and NY coordinates of the C grid lines in X- and Y-directions, respectively. These C should be strictly increasing. C C W is an array of the NX * NY functional values at the C the grid points, i. e. W(I,J) contains the functional C value at (X(I),Y(J)) for I = 1,...,NX, and J = 1,...,NY. C C NW1 is the first dimension of the array W used in the C calling program (NW1 .GE. NX). C C C is an array of at least NX * NY locations. This C parameter may coincide with W in which case W is C destroyed on output. C C VX and VY are arrays of at least 5 * NX and 5 * NY C locations, respectively. C C Temp is an array of at least 3 * MAX(NX, NY) locations C which is used for scratch storage. C C And C C SIGMA contains the tension factor. This value indicate C the curviness desired. If ABS(SIGMA) is nearly zero C (e. G. .001) the resulting surface is approximately the C tensor product of cubic splines. If ABS(SIGMA) is large C (e. G. 50.) the resulting surface is approximately C bi-linear. If SIGMA equals zero tensor products of cubic C splines result. A standard value for SIGMA is C approximately 1. In absolute value. C C On output-- C C C contains the coefficients of a representation of the C interpolated function in a B-spline tensor production C form. C C VX and VY contain B-spline under tension basis data. C C IERR contains an error flag. C = 0 for normal return, C = 1 if NX or NY is less than 2, C = 2 if the X- or Y-arrays are not strictly C increasing. C C And C C None of the input parameters are altered (except W if C this parameter and C are identical in the calling C sequence). C C This subroutine references package modules VGEN, TERMS, C SNHCSH, TRIDEC, and TRISOL. C C--------------------------------------------------------- - C C Copy W into C C DO 1 J = 1,NY DO 1 I = 1,NX 1 C(I,J) = W(I,J) C C Generate basis functions along X-grid C set up tridiagonal system and solve C CALL VGEN (NX,X,SIGMA,VX,IERR) IF (IERR .NE. 0) RETURN DO 2 I = 2,NX 2 TEMP(I) = VX(5,I-1) NXPI = NX DO 3 I = 1,NX NXPI = NXPI+1 3 TEMP(NXPI) = 1. DO 4 I = 2,NX NXPI = NXPI+1 4 TEMP(NXPI) = VX(4,I) CALL TRIDEC (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1), * TEMP(1),TEMP(NX+1),IERR) CALL TRISOL (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1),C,NX, * NY,1) C C Generate basis functions along Y-grid C set up tridiagonal system and solve C CALL VGEN (NY,Y,SIGMA,VY,IERR) IF (IERR .NE. 0) RETURN DO 5 J = 2,NY 5 TEMP(J) = VY(5,J-1) NYPJ = NY DO 6 J = 1,NY NYPJ = NYPJ+1 6 TEMP(NYPJ) = 1. DO 7 J = 2,NY NYPJ = NYPJ+1 7 TEMP(NYPJ) = VY(4,J) CALL TRIDEC (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1), * TEMP(1),TEMP(NY+1),IERR) CALL TRISOL (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1),C,1, * NX,NX) RETURN END C C======================================================================= C C C SUBROUTINE VAL3B1 (NX,NY,NZ,X,Y,Z,W,NW1,NW2,C,VX,VY, * VZ,TEMP,SIGMA,IERR) C INTEGER NX,NY,NZ,NW1,NW2,IERR REAL X(NX),Y(NY),Z(NZ),W(NW1,NW2,NZ),C(NX,NY,NZ), * VX(5,NX),VY(5,NY),VZ(5,NZ),TEMP(*),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines the parameters necessary to C compute an interpolatory function on a three dimensional C rectangular grid. The function determined can be C represented as a tensor product of splines under tension. C For actual mapping of points it is necessary to call the C subroutine VAL3BD, which also returns first and second C partial derivatives. C C On input-- C C NX, NY, and NZ are the number of grid lines in the X-, C Y-, and Z-directions, respectively, of the rectangular C grid. (NX, NY, and NZ should be at least 2.) C C X, Y, and Z are arrays of the NX, NY, and NZ coordinates C of the grid lines in the X-, Y-, and Z-directions, C respectively. These should be strictly increasing. C C W is an array of the NX * NY * NZ functional values at C the grid points, i. e. W(I,J,K) contains the functional C value at (X(I),Y(J),Z(K)) for I = 1,...,NX, C J = 1,...,NY, and K = 1,...,NZ. C C NW1 and NW2 are the first two dimensions of the array W C used in the calling program (NW1 .GE. NX AND NW2 .GE. C NY). C C C is an array of at least NX * NY * NZ locations. This C parameter may coincide with W in which case W is C destroyed on output. C C VX, VY, and VZ are arrays of at least 5 * NX, 5 * NY, C and 5 * NZ locations, respectively. C C Temp is an array of at least 3 * MAX(NX, NY, NZ) C locations which is used for scratch storage. C C And C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the resulting surface is approximately the C tensor product of cubic splines. If ABS(SIGMA) is large C (e. g. 50.) the resulting surface is approximately C tri-linear. If SIGMA equals zero tensor products of C cubic splines result. A standard value for SIGMA is C approximately 1. In absolute value. C C On output-- C C C contains the coefficients of a representation of the C interpolated function in a B-spline tensor production C form. C C VX, VY, and VZ contain B-spline under tension basis C data. C C IERR contains an error flag. C = 0 for normal return, C = 1 if NX, NY, or NZ is less than 2, C = 2 if the X-, Y-, or Z-arrays are not strictly C increasing. C C And C C None of the input parameters are altered (except W if C this parameter and C are identical in the calling C sequence). C C This subroutine references package modules VGEN, TERMS, C SNHCSH, TRIDEC, and TRISOL. C C----------------------------------------------------------- C C Copy W into C C DO 1 K = 1,NZ DO 1 J = 1,NY DO 1 I = 1,NX 1 C(I,J,K) = W(I,J,K) C C Generate basis functions along X-grid C set up tridiagonal system and solve C CALL VGEN (NX,X,SIGMA,VX,IERR) IF (IERR .NE. 0) RETURN DO 2 I = 2,NX 2 TEMP(I) = VX(5,I-1) NXPI = NX DO 3 I = 1,NX NXPI = NXPI+1 3 TEMP(NXPI) = 1. DO 4 I = 2,NX NXPI = NXPI+1 4 TEMP(NXPI) = VX(4,I) CALL TRIDEC (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1), * TEMP(1),TEMP(NX+1),IERR) CALL TRISOL (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1),C,NX, * NY*NZ,1) C C Generate basis functions along Y-grid C set up tridiagonal system and solve C CALL VGEN (NY,Y,SIGMA,VY,IERR) IF (IERR .NE. 0) RETURN DO 5 J = 2,NY 5 TEMP(J) = VY(5,J-1) NYPJ = NY DO 6 J = 1,NY NYPJ = NYPJ+1 6 TEMP(NYPJ) = 1. DO 7 J = 2,NY NYPJ = NYPJ+1 7 TEMP(NYPJ) = VY(4,J) CALL TRIDEC (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1), * TEMP(1),TEMP(NY+1),IERR) DO 8 K = 1,NZ 8 CALL TRISOL (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1),C(1,1,K), * 1,NX,NX) C C Generate basis functions along Z-grid C set up tridiagonal system and solve C CALL VGEN (NZ,Z,SIGMA,VZ,IERR) IF (IERR .NE. 0) RETURN DO 9 K = 2,NZ 9 TEMP(K) = VZ(5,K-1) NZPK = NZ DO 10 K = 1,NZ NZPK = NZPK+1 10 TEMP(NZPK) = 1. DO 11 K = 2,NZ NZPK = NZPK+1 11 TEMP(NZPK) = VZ(4,K) CALL TRIDEC (NZ,TEMP(1),TEMP(NZ+1),TEMP(2*NZ+1), * TEMP(1),TEMP(NZ+1),IERR) CALL TRISOL (NZ,TEMP(1),TEMP(NZ+1),TEMP(2*NZ+1),C,1, * NX*NY,NX*NY) RETURN END C C======================================================================= C C C SUBROUTINE VGEN (N,X,SIGMA,V,IERR) C INTEGER N,IERR REAL X(N),SIGMA,V(5,N) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine generates an array of coefficients used by C other subroutines for the determination of a B-spline C under tension basis. C C On input-- C C N is the number of knots defining the basis (N .GE. 2). C C X is the array of the N increasing knots. Any linear C combination of the resulting basis will have third C derivative discontinuities only at the interior knots, C (i. e. X(2),...,X(N-1) ). C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the basis functions are approximately cubic C splines. If ABS(SIGMA) is large (e. g. 50.) the basis C functions are nearly piecewise linear. If SIGMA equals C zero a cubic spline basis results. A standard value for C SIGMA is approximately 1. In absolute value. C C And C C V is an array of at least 5*N locations. C C On output-- C C V contains certain coefficients to be used by other C subprograms for the determination of the B-spline under C tension basis. Considered as a 5 by N array, for I = 1, C ... , N, B-spline basis function I is specified by-- C V(1,I) = second derivative at X(I-1), for I .NE. 1, C V(2,I) = second derivative at X(I), for all I, C V(3,I) = second derivative at X(I+1), for I .NE. N, C V(4,I) = function value at X(I-1), for I .NE. 1, C V(5,I) = function value at X(I+1), for I .NE. N, C and the properties that it has-- C 1. Function value 1 at X(I), C 2. Function value and second derivative = 0 at C X(1), ... , X(I-2), and X(I+2), ... , X(N). C In V(5,N) and V(3,N) are contained function value and C second derivative of basis function zero at X(1), C respectively. In V(4,1) and V(1,1) are contained C function value and second derivative of basis function C N+1 at X(N), respectively. Function value and second C derivative of these two basis functions are zero at all C other knots. Only basis function zero has non-zero C second derivative value at X(1) and only basis C function N+1 has non-zero second derivative at X(N). C C IERR contains an error flag, C = 0 for normal return, C = 1 if N is less than 2, C = 2 if X-values are not strictly increasing. C C And C C N, X, and SIGMA are unaltered. C C This subroutine references package modules TERMS and C SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 IERR = 0 IF (N .LE. 1) GO TO 3 IF (X(N) .LE. X(1)) GO TO 4 C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Generate coefficients for left end basis functions C D3 = X(2)-X(1) IF (D3 .LE. 0.) GO TO 4 CALL TERMS (DIAG3,SDIAG3,SIGMAP,D3) D4 = D3 IF (N .GE. 3) D4 = X(3)-X(2) IF (D4 .LE. 0.) GO TO 4 CALL TERMS (DIAG4,SDIAG4,SIGMAP,D4) A22 = DIAG3+SDIAG3 A23 = DIAG3+DIAG4+SDIAG3+SDIAG4 V(2,1) = 0. V(3,1) = 1./(D3*(DIAG3+DIAG4)+(D3+D4)*SDIAG4) V(5,1) = SDIAG4*D4*V(3,1) IF (N .EQ. 2) GO TO 2 A22 = 2.*A22 D1 = D3 D2 = D3 D3 = D4 DIAG1 = DIAG3 DIAG2 = DIAG3 DIAG3 = DIAG4 SDIAG1 = SDIAG3 SDIAG2 = SDIAG3 SDIAG3 = SDIAG4 C C Generate coefficients for interior basis functions C DO 1 I = 2,NM1 IF (I .NE. NM1) D4 = X(I+2)-X(I+1) IF (D4 .LE. 0.) GO TO 4 IF (D4 .NE. D3) CALL TERMS (DIAG4,SDIAG4,SIGMAP,D4) A11 = DIAG1+DIAG2+SDIAG1*(1.+D1/D2) A12 = SDIAG2/A11 B1 = 1./(D2*A11) A33 = DIAG3+DIAG4+SDIAG4*(1.+D4/D3) A32 = SDIAG3/A33 B3 = 1./(D3*A33) A21 = A22 A22 = A23 A23 = DIAG3+DIAG4+SDIAG3+SDIAG4 V(2,I) = -(A21*B1+A23*B3)/(A22-A21*A12-A23*A32) V(1,I) = B1-A12*V(2,I) V(3,I) = B3-A32*V(2,I) V(4,I) = SDIAG1*D1*V(1,I) V(5,I) = SDIAG4*D4*V(3,I) C C Save constants for next iteration C D1 = D2 D2 = D3 D3 = D4 DIAG1 = DIAG2 DIAG2 = DIAG3 DIAG3 = DIAG4 SDIAG1 = SDIAG2 SDIAG2 = SDIAG3 1 SDIAG3 = SDIAG4 C C Generate coefficients for right end basis functions C V(2,N) = 0. V(1,N) = 1./(D2*(DIAG1+DIAG2)+(D2+D1)*SDIAG1) V(4,N) = SDIAG1*D1*V(1,N) V(3,N) = V(1,3) V(5,N) = V(4,3) V(1,1) = V(3,N-2) V(4,1) = V(5,N-2) C C Adjust basis for natural end conditions C V(4,2) = V(4,2)-V(1,2)*V(5,N)/V(3,N) V(1,2) = 0. V(5,NM1) = V(5,NM1)-V(3,NM1)*V(4,1)/V(1,1) V(3,NM1) = 0. RETURN C C N equal to 2 C 2 V(4,1) = V(5,1) V(1,1) = V(3,1) V(3,1) = 0. V(5,1) = 0. V(1,2) = 0. V(2,2) = 0. V(3,2) = V(1,1) V(4,2) = 0. V(5,2) = V(4,1) RETURN C C Too few knots C 3 IERR = 1 RETURN C C X-values not strictly increasing C 4 IERR = 2 RETURN END C C======================================================================= C C C SUBROUTINE TERMS (DIAG,SDIAG,SIGMA,DEL) C REAL DIAG,SDIAG,SIGMA,DEL C C From FITPACK -- August 31, 1981 C Coded by A. K. Cline and R. J. Renka C Department of Computer Sciences C University of Texas at Austin C C This subroutine computes the diagonal and superdiagonal C terms of the tridiagonal linear system associated with C spline under tension interpolation. C C On input-- C C SIGMA contains the tension factor. C C And C C DEL contains the step size. C C On output-- C C (SIGMA*DEL*COSH(SIGMA*DEL) - SINH(SIGMA*DEL) C DIAG = DEL*--------------------------------------------. C (SIGMA*DEL)**2 * SINH(SIGMA*DEL) C C SINH(SIGMA*DEL) - SIGMA*DEL C SDIAG = DEL*----------------------------------. C (SIGMA*DEL)**2 * SINH(SIGMA*DEL) C C And C C SIGMA and DEL are unaltered. C C This subroutine references package module SNHCSH. C C----------------------------------------------------------- C IF (SIGMA .NE. 0.) GO TO 1 DIAG = DEL/3. SDIAG = DEL/6. RETURN 1 SIGDEL = SIGMA*DEL CALL SNHCSH (SINHM,COSHM,SIGDEL,0) DENOM = DEL/((SINHM+SIGDEL)*SIGDEL*SIGDEL) DIAG = DENOM*(SIGDEL*COSHM-SINHM) SDIAG = DENOM*SINHM RETURN END C C======================================================================= C C C SUBROUTINE TRIDEC (N,SUBDI,DIAGI,SUPD,SUBDO,DIAGO, * IERR) C INTEGER N,IERR REAL SUBDI(N),DIAGI(N),SUPD(N),SUBDO(N),DIAGO(N) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine factorizes a tridiagonal matrix in order C to solve systems of linear equations. The factorization C employs gaussian elimination without any interchanging of C columns or rows. The subroutine trisol may be called to C actually solve the system once the factorization has been C performed. C C On input-- C C N contains the order of the matrix (N .GE. 1). C C SUBDI is an array containing the subdiagonal elements of C the matrix in positions 2, ... , N. C C DIAGI is an array containing the diagonal elements of C the matrix. C C SUPD is an array containing the superdiagonal elements C of the matrix in positions 1, ... , N-1. C C And C C SUBDO and DIAGO are arrays of length N. (The storage C for these may coincide with that for SUBDI and DIAGI, C respectively, in which case the original contents of C SUBDI and DIAGI will be destroyed.) C C On output-- C C SUBDO and DIAGO contain the subdiagonal and diagonal of C the factorization matrix. C C IERR contains an error flag, C = 0 for normal return, C = 1 if N is less than 1, C = 2 if the system is singular. C C And C C N, SUBDI, DIAGI, and SUPD are unaltered (unless storage C for SUBDI or DIAGI coincided with that for SUBDO C or DIAGO, respectively). C C----------------------------------------------------------- C IF (N .LE. 0) GO TO 3 IERR = 2 DIAGO(1) = DIAGI(1) IF (N .EQ. 1) GO TO 2 C C Forward elimination C DO 1 I = 2,N IM1 = I-1 IF (DIAGO(IM1) .EQ. 0.) RETURN DIAGO(IM1) = 1./DIAGO(IM1) SUBDO(I) = SUBDI(I)*DIAGO(IM1) 1 DIAGO(I) = DIAGI(I)-SUBDO(I)*SUPD(IM1) 2 IF (DIAGO(N) .EQ. 0.) RETURN DIAGO(N) = 1./DIAGO(N) IERR = 0 RETURN C C N less than 1 C 3 IERR = 1 RETURN END C C======================================================================= C C C SUBROUTINE TRISOL (N,SUBD,DIAG,SUPD,RHS,MRHS,NUMRHS, * INCRHS) C INTEGER N,MRHS,NUMRHS,INCRHS REAL SUBD(N),DIAG(N),SUPD(N) REAL RHS(1+INCRHS*(N-1)+MRHS*(NUMRHS-1)) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C Revised -- December 31, 1992 C by Ludek Klimes C Institute of Geotechnics C Czechosl. Acad. Sci., Prague C C This subroutine solves tridiagonal systems of linear C equations with multiple right hand sides. The right hand C sides may be stored row-wise or column-wise. The C subroutine TRIDEC should be called earlier to determine a C factorization of the tridiagonal matrix. The solution C vectors over-write the right hand sides. C C On input-- C C N contains the order of the matrix (N .GE. 1). C C SUBD, DIAG, and SUPD are arrays of length N containing C the subdiagonal, diagonal, and superdiagonal of the C factorization, respectively. C C RHS is an array containing the right hand sides of the C tridiagonal system. C C MRHS is the increment between the first components of C each of the right hand side vectors in storage (MRHS C .GE. 1). C C NUMRHS is the number of right hand sides to be solved. C C And C C INCRHS is the increment between components within each C of the right hand side vectors in storage (INCRHS .GE. C 1). C C The parameters N, SUBD, DIAG, and SUPD may be input as the C parameters N, SUBDO, DIAGO, and SUPD output by subroutine C TRIDEC, respectively. C C On output-- C C RHS contains the solution vectors in the same storage C structure as for the right hand sides. C C And C C N, SUBD, DIAG, SUPD, MRHS, NUMRHS, and INCRHS are C unaltered. C C----------------------------------------------------------- C NP1 = N+1 C C Loop on right hand sides C DO 4 K = 1,NUMRHS C C Forward elimination C IRHS = 1+MRHS*(K-1) IF (N .EQ. 1) GO TO 2 DO 1 I = 2,N IM1RHS = IRHS IRHS = IRHS+INCRHS 1 RHS(IRHS) = RHS(IRHS)-SUBD(I)*RHS(IM1RHS) C C Back substitution C 2 RHS(IRHS) = DIAG(N)*RHS(IRHS) IF (N .EQ. 1) GO TO 4 DO 3 IBAK = 2,N I = NP1-IBAK RHS(IM1RHS) = DIAG(I)*(RHS(IM1RHS)-SUPD(I) * *RHS(IRHS)) IRHS = IM1RHS 3 IM1RHS = IM1RHS-INCRHS 4 CONTINUE RETURN END C C======================================================================= C C Part 2: C C======================================================================= C C C SUBROUTINE CURV2D (T,YY,YX,YXX,N,X,Y,YP,SIGMA) C INTEGER N REAL T,YY,YX,YXX,X(N),Y(N),YP(N),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines function value, first, and C second derivatives of a curve at a given point using a C spline under tension. The subroutine CURV1 should be C called earlier to determine certain necessary parameters. C C On input-- C C T contains a real value at which the function and C derivatives are to be evaluated. C C N contains the number of points which were specified to C determine the curve. C C X and Y are arrays containing the abscissae and C ordinates, respectively, of the specified points. C C YP is an array of second derivative values of the curve C at the nodes. C C And C C SIGMA contains the tension factor (its sign is ignored). C C The parameters N, X, Y, YP, and SIGMA should be input C unaltered from the output of CURV1. C C On output-- C C YY, YX, and YXX contain the function value, first and C second derivatives, respectively. C C None of the input parameters are altered. C C This subroutine references package modules INTRVL and C SNHCSH. C C----------------------------------------------------------- C C Determine interval C IM1 = INTRVL(T,X,N) I = IM1+1 C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Set up and perform interpolation C DEL1 = T-X(IM1) DEL2 = X(I)-T DELS = X(I)-X(IM1) YY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS YX = (Y(I)-Y(IM1))/DELS IF (SIGMAP .NE. 0.) GO TO 1 YY = YY-DEL1*DEL2*(YP(I)*(DEL1+DELS)+YP(IM1)* * (DEL2+DELS))/(6.*DELS) YX = YX+(YP(I)*(2.*DEL1*DEL1-DEL2*(DEL1+DELS))- * YP(IM1)*(2.*DEL2*DEL2-DEL1*(DEL2+DELS))) * /(6.*DELS) YXX = (YP(I)*DEL1+YP(IM1)*DEL2)/DELS RETURN 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH (SINHM1,COSHM1,SIGMAP*DEL1,0) CALL SNHCSH (SINHM2,COSHM2,SIGMAP*DEL2,0) CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) YY = YY+(YP(I)*(SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)* * SINHP2+SIGMAP*COSHP1*DEL2))+YP(IM1)*(SINHM2* * DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP* * COSHP2*DEL1)))/(SIGMAP*SIGMAP*DELS*(SINHMS+ * SIGMAP*DELS)) YX = YX+(YP(I)*(DELS*SIGMAP*COSHM1-SINHMS)- * YP(IM1)*(DELS*SIGMAP*COSHM2-SINHMS))/ * (SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)) YXX = (YP(I)*(SINHM1+SIGMAP*DEL1)+YP(IM1)*(SINHM2+ * SIGMAP*DEL2))/(SINHMS+SIGMAP*DELS) RETURN END C C======================================================================= C C C SUBROUTINE CURVBD (XX,W,WX,WXX,NX,X,C,VX,SIGMA) C INTEGER NX REAL XX,W,WX,WXX,X(NX),VX(5,NX),C(NX),SIGMA C C Complement to FITPACK C by Alan Kaylor Cline C Coded -- October 9, 1986 C by Ludek Klimes C Inst. Geol. Geotechn. C Czechosl. Acad. Sci., Prague C C This subroutine evaluates the function value, the C first partial derivative, and the second partial C derivative of a spline under tension in one variable. C C On input-- C C XX contains the X-coordinate of the point C at which the interpolation is to be performed C C NX is the number of grid points C C X is array containing the X-grid values. C C C is an array of coefficients describing the function in C terms of a B-spline under tension basis. In the C expansion of the function, for I = 1,...,NX , C the coefficient multiplying the basis C function I is stored in C(I). C C VX is the array of length 5*NX C containing the B-spline basis data C C SIGMA contains the tension factor (its sign is ignored). C C The parameters NX, X, C, VX, and SIGMA C should be input unaltered from the output of CURVB1. C C On output-- C C W contains the interpolated function value. C C WX contains the first derivative . C C WXX contains the second derivative . C C And C C None of the input parameters are altered. C C This subroutine references package modules DSPLNZ, INTRVL, C and SNHCSH. C C-------------------------------------------------------------- C REAL BX(3,4) C C Evaluate basis functions at XX C CALL DSPLNZ (XX,NX,X,VX,SIGMA,ISTART,BX) C C Accumulate basis functions C SUM = 0. SUMX = 0. SUMXX = 0. DO 1 I = 1,4 II = ISTART+I-1 IF (II .EQ. 0 .OR. II .GT. NX) GO TO 1 BX1I = BX(1,I) CI = C(II) SUM = SUM+CI*BX1I SUMX = SUMX+CI*BX(2,I) SUMXX = SUMXX+CI*BX(3,I) *V CALL VAR2(II,BX1I,BX(2,I),0.,0.) 1 CONTINUE W = SUM WX = SUMX WXX = SUMXX RETURN END C C======================================================================= C C C SUBROUTINE SURFBD (XX,YY,W,WX,WY,WXX,WXY,WYY,NX,NY,X, * Y,C,VX,VY,SIGMA) C INTEGER NX,NY REAL XX,YY,W,WX,WY,WXX,WXY,WYY,X(NX),Y(NY),VX(5,NX), * VY(5,NY),C(NX,NY),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine evaluates the function value, the two C first partial derivatives, and the six second partial C derivatives of a tensor product spline under tension in C two variables. C C On input-- C C XX and YY contain the X- and Y-coordinates of the point C at which the interpolation is to be performed. C C NX and NY are the number of grid lines in the X- and Y- C directions, respectively, of the rectangular grid which C specified the function. C C X and Y are arrays containing the X- and Y-grid values, C respectively. C C C is an array of coefficients describing the function in C terms of a B-spline under tension basis. In the C expansion of the function, for I = 1,...,NX and J = 1, C ...,NY, the coefficient multiplying the product of basis C function I in X and basis function J in Y is stored in C C(I,J). C C VX and VY VZ are arrays of length 5*NX and 5*NY, C respectively, containing the B-spline basis data for the C X- and Y-grids. C C And C C SIGMA contains the tension factor (its sign is ignored). C C The parameters NX, NY, X, Y, Z, C, VX, VY, and SIGMA C should be input unaltered from the output of SURFB1. C C On output-- C C W contains the interpolated function value. C C WX and WY contain the X- and Y-partial derivatives, C respectively. C C WXX, WXY, and WYY contain the XX-, XY-, and YY-partial C derivatives, respectively. C C And C C None of the input parameters are altered. C C This subroutine references package modules DSPLNZ, INTRVL, C and SNHCSH. C C--------------------------------------------------------- ---- C REAL BX(3,4),BY(3,4) C C Evaluate basis functions at XX and YY C CALL DSPLNZ (XX,NX,X,VX,SIGMA,ISTART,BX) CALL DSPLNZ (YY,NY,Y,VY,SIGMA,JSTART,BY) C C Accumulate tensor products C SUM = 0. SUMX = 0. SUMY = 0. SUMXX = 0. SUMXY = 0. SUMYY = 0. DO 2 J = 1,4 JJ = JSTART+J-1 IF (JJ .EQ. 0 .OR. JJ .GT. NY) GO TO 2 BY1J = BY(1,J) BY2J = BY(2,J) BY3J = BY(3,J) DO 1 I = 1,4 II = ISTART+I-1 IF (II .EQ. 0 .OR. II .GT. NX) GO TO 1 BX1I = BX(1,I) BX2I = BX(2,I) CIJ = C(II,JJ) SUM = SUM+CIJ*BX1I*BY1J SUMX = SUMX+CIJ*BX2I*BY1J SUMY = SUMY+CIJ*BX1I*BY2J SUMXX = SUMXX+CIJ*BX(3,I)*BY1J SUMXY = SUMXY+CIJ*BX2I*BY2J SUMYY = SUMYY+CIJ*BX1I*BY3J *V CALL VAR2(II+NX*(JJ-1),BX1I*BY1J,BX2I*BY1J,BX1I*BY2J,0.) 1 CONTINUE 2 CONTINUE W = SUM WX = SUMX WY = SUMY WXX = SUMXX WXY = SUMXY WYY = SUMYY RETURN END C C======================================================================= C C C SUBROUTINE VAL3BD (XX,YY,ZZ,W,WX,WY,WZ,WXX,WXY,WYY, * WYZ,WZZ,WXZ,NX,NY,NZ,X,Y,Z,C,VX,VY, * VZ,SIGMA) C INTEGER NX,NY,NZ REAL XX,YY,ZZ,W,WX,WY,WZ,WXX,WXY,WYY,WYZ,WZZ,WXZ, * X(NX),Y(NY),Z(NZ),VX(5,NX),VY(5,NY),VZ(5,NZ), * C(NX,NY,NZ),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine evaluates the function value, the three C first partial derivatives, and the six second partial C derivatives of a tensor product spline under tension in C three variables. C C On input-- C C XX, YY, and ZZ contain the X-, Y-, and Z-coordinates of C the point at which the interpolation is to be performed. C C NX, NY, and NZ are the number of grid lines in the X-, C Y-, and Z-directions, respectively, of the rectangular C grid which specified the function. C C X, Y, and Z are arrays containing the X-, Y-, and Z-grid C values, respectively. C C C is an array of coefficients describing the function in C terms of a B-spline under tension basis. In the C expansion of the function, for I = 1,...,NX, J = 1,..., C NY, AND K = 1,...,NZ, the coefficient multiplying the C product of basis function I in X, basis function J in Y, C and basis function K in Z is stored in C(I,J,K). C C VX, VY, and VZ are arrays of length 5*NX, 5*NY, and C 5*NZ, respectively, containing the B-spline basis data C for the X-, Y-, and Z-grids. C C And C C SIGMA contains the tension factor (its sign is ignored). C C The parameters NX, NY, NZ, X, Y, Z, C, VX, VY, VZ, and C SIGMA should be input unaltered from the output of C VAL3B1. C C On output-- C C W contains the interpolated function value. C C WX, WY, and WZ contain the X-, Y-, and Z-partial C derivatives, respectively. C C WXX, WXY, WYY, WYZ, WZZ, and WXZ contain the XX-, XY- C YY-, YZ-, ZZ-, and XZ-partial derivatives, respectively. C C And C C None of the input parameters are altered. C C This subroutine references package modules DSPLNZ, INTRVL, C and SNHCSH. C C-------------------------------------------------------------- C REAL BX(3,4),BY(3,4),BZ(3,4) C C Evaluate basis functions at XX, YY, and ZZ C CALL DSPLNZ (XX,NX,X,VX,SIGMA,ISTART,BX) CALL DSPLNZ (YY,NY,Y,VY,SIGMA,JSTART,BY) CALL DSPLNZ (ZZ,NZ,Z,VZ,SIGMA,KSTART,BZ) C C Accumulate tensor products C SUM = 0. SUMX = 0. SUMY = 0. SUMZ = 0. SUMXX = 0. SUMXY = 0. SUMYY = 0. SUMYZ = 0. SUMZZ = 0. SUMXZ = 0. DO 3 K = 1,4 KK = KSTART+K-1 IF (KK .EQ. 0 .OR. KK .GT. NZ) GO TO 3 BZ1K = BZ(1,K) BZ2K = BZ(2,K) BZ3K = BZ(3,K) DO 2 J = 1,4 JJ = JSTART+J-1 IF (JJ .EQ. 0 .OR. JJ .GT. NY) GO TO 2 BY1J = BY(1,J) BY2J = BY(2,J) BY3J = BY(3,J) DO 1 I = 1,4 II = ISTART+I-1 IF (II .EQ. 0 .OR. II .GT. NX) GO TO 1 BX1I = BX(1,I) BX2I = BX(2,I) CIJK = C(II,JJ,KK) SUM = SUM+CIJK*BX1I*BY1J*BZ1K SUMX = SUMX+CIJK*BX2I*BY1J*BZ1K SUMY = SUMY+CIJK*BX1I*BY2J*BZ1K SUMZ = SUMZ+CIJK*BX1I*BY1J*BZ2K SUMXX = SUMXX+CIJK*BX(3,I)*BY1J*BZ1K SUMXY = SUMXY+CIJK*BX2I*BY2J*BZ1K SUMYY = SUMYY+CIJK*BX1I*BY3J*BZ1K SUMYZ = SUMYZ+CIJK*BX1I*BY2J*BZ2K SUMZZ = SUMZZ+CIJK*BX1I*BY1J*BZ3K SUMXZ = SUMXZ+CIJK*BX2I*BY1J*BZ2K *V CALL VAR2(II+NX*(JJ-1+NY*(KK-1)),BX1I*BY1J*BZ1K, *V * BX2I*BY1J*BZ1K,BX1I*BY2J*BZ1K,BX1I*BY1J*BZ2K) 1 CONTINUE 2 CONTINUE 3 CONTINUE W = SUM WX = SUMX WY = SUMY WZ = SUMZ WXX = SUMXX WXY = SUMXY WYY = SUMYY WYZ = SUMYZ WZZ = SUMZZ WXZ = SUMXZ RETURN END C C======================================================================= C C C SUBROUTINE DSPLNZ (T,N,X,V,SIGMA,ISTART,B) C INTEGER N,ISTART REAL T,X(N),V(5,N),SIGMA,B(3,4) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine evaluates at a given point the four non- C zero basis functions of a B-spline under tension basis and C their first and second derivatives. The index of the first C non-zero basis function is also determined. (the sense of C the word non-zero is extended to include the special case C where the given point coincides with a knot in which case C the last of the four returned function values may be zero. C ) the subroutine VGEN should be called earlier to C determine certain necessary coefficients. C C On input-- C C T contains a real value at which the basis functions are C to be evaluated. C C N contains the number of knots defining the basis. C C X contains the array of knots. C C V contains the array of coefficients determined by VGEN C for calculation of basis functions. C C SIGMA contains the tension factor (its sign is ignored). C C ISTART is an integer variable. C C And C C B is a real array with 3 rows and 4 columns. C C The parameters N, X, V, and SIGMA should be input C unaltered from the output of VGEN. C C On output-- C C ISTART contains the index of the first non-zero basis C function. Thus 0 .LE. ISTART .LE. N-2 and the non-zero C basis functions have indices ISTART, ... , ISTART+3. C C B contains the values at T of basis functions ISTART, C ... , ISTART+3 in B(1,1), ... , B(1,4), respectively. C First and second derivatives of the corresponding C functions are contained in B(2,1), ... , B(2,4), and C B(3,1), ... , B(3,4), respectively. C C T, N, X, V, and SIGMA are unaltered. C C This subroutine references package modules INTRVL and C SNHCSH. C C----------------------------------------------------------- C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Determine index of first non-zero basis function C I = INTRVL (T,X,N)-1 C C Compute distances to adjacent knots and lagrangian C weights C DEL1 = T-X(I+1) DEL2 = X(I+2)-T DELS = X(I+2)-X(I+1) C10 = DEL2/DELS C20 = DEL1/DELS C11 = -1./DELS C21 = 1./DELS IF (SIGMAP .NE. 0.) GO TO 1 FAC = -DEL1*DEL2/(6.*DELS) CP10 = FAC*(DEL2+DELS) CP20 = FAC*(DEL1+DELS) CP11 = -(2.*DEL2*DEL2-DEL1*(DEL2+DELS))/(6.*DELS) CP21 = (2.*DEL1*DEL1-DEL2*(DEL1+DELS))/(6.*DELS) CP12 = C10 CP22 = C20 GO TO 2 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH (SINHM1,COSHM1,SIGMAP*DEL1,0) CALL SNHCSH (SINHM2,COSHM2,SIGMAP*DEL2,0) CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) SINHS = SINHMS+SIGMAP*DELS DENOM = SIGMAP*SIGMAP*DELS*SINHS CP10 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1 * +SIGMAP*COSHP2*DEL1))/DENOM CP20 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2 * +SIGMAP*COSHP1*DEL2))/DENOM CP11 = -(DELS*SIGMAP*COSHM2-SINHMS)/DENOM CP21 = (DELS*SIGMAP*COSHM1-SINHMS)/DENOM CP12 = (SINHM2+SIGMAP*DEL2)/SINHS CP22 = (SINHM1+SIGMAP*DEL1)/SINHS C C Compute basis function values C 2 II = I IF (II .EQ. 0) II = N IIP1 = I+1 IIP2 = I+2 IIP3 = I+3 IF (IIP2 .EQ. N) IIP3 = 1 B(1,1) = C10*V(5,II)+CP10*V(3,II) B(1,2) = C10+C20*V(5,IIP1)+CP10*V(2,IIP1)+ * CP20*V(3,IIP1) B(1,3) = C10*V(4,IIP2)+C20+CP10*V(1,IIP2)+ * CP20*V(2,IIP2) B(1,4) = C20*V(4,IIP3)+CP20*V(1,IIP3) B(2,1) = C11*V(5,II)+CP11*V(3,II) B(2,2) = C11+C21*V(5,IIP1)+CP11*V(2,IIP1)+ * CP21*V(3,IIP1) B(2,3) = C11*V(4,IIP2)+C21+CP11*V(1,IIP2)+ * CP21*V(2,IIP2) B(2,4) = C21*V(4,IIP3)+CP21*V(1,IIP3) B(3,1) = CP12*V(3,II) B(3,2) = CP12*V(2,IIP1)+CP22*V(3,IIP1) B(3,3) = CP12*V(1,IIP2)+CP22*V(2,IIP2) B(3,4) = CP22*V(1,IIP3) ISTART = I RETURN END C C======================================================================= C C C FUNCTION INTRVL (T,X,N) C INTEGER N REAL T,X(N) C C From FITPACK -- August 31, 1981 C Coded by A. K. Cline and R. J. Renka C Department of Computer Sciences C University of Texas at Austin C C This function determines the index of the interval C (determined by a given increasing sequence) in which C a given value lies. C C On input-- C C T is the given value. C C X is a vector of strictly increasing values. C C And C C N is the length of X (N .GE. 2). C C On output-- C C INTRVL returns an integer I such that C C I = 1 if T .LT. X(2) , C I = N-1 if X(N-1) .LE. T , C otherwise X(I) .LE. T .LT. X(I+1), C C None of the input parameters are altered. C C----------------------------------------------------------- C TT = T IF (TT .LT. X(2)) GO TO 4 IF (TT .GE. X(N-1)) GO TO 5 IL = 2 IH = N-1 C C Linear interpolation C 1 I = MIN0(IL+IFIX(FLOAT(IH-IL)*(TT-X(IL))/(X(IH)-X(IL))), * IH-1) IF (TT .LT. X(I)) GO TO 2 IF (TT .LT. X(I+1)) GO TO 3 C C Too high C IL = I+1 GO TO 1 C C Too low C 2 IH = I GO TO 1 3 INTRVL = I RETURN C C Left end C 4 INTRVL = 1 RETURN C C Right end C 5 INTRVL = N-1 RETURN END C C======================================================================= Cfitv.for 0100666 0000765 0000765 00000147275 06730116202 012126 0 ustar bulant bulant C
C Subroutines of the software package 'FITPACK' by A.K. Cline C used to specify the model for the complete ray tracing algorithm. C C This file consists of the following parts: C (0) Auxiliary subroutine C SNHCSH C SNHCSH C common to all the following parts. C (1) The subroutines preparing the parameters necessary to compute C an interpolatory function: C CURVN1 (Hermite representation of 1-D function), C CURVB1 (B-spline representation of 1-D function), C SURFB1 (B-spline representation of 2-D function), C VAL3B1 (B-spline representation of 3-D function), C VGEN (auxiliary subroutine), C TERMS (auxiliary subroutine), C TRIDEC (auxiliary subroutine), C TRISOL (auxiliary subroutine). C CURVN1 C CURVB1 C SURFB1 C VAL3B1 C VGEN C TERMS C TRIDEC C TRISOL C Subroutines CURVN1 and CURVB1 are alternatives. C (2) The subroutines evaluating the value, first and second partial C derivatives of the interpolatory function at a given point: C CURV2D (Hermite representation of 1-D function), C CURVBD (B-spline representation of 1-D function), C SURFBD (B-spline representation of 2-D function), C VAL3BD (B-spline representation of 3-D function), C DSPLNZ (auxiliary subroutine), C INTRVL (auxiliary external function). C CURV2D C CURVBD C SURFBD C VAL3BD C DSPLNZ C INTRVL C Subroutines CURV2D and CURVBD are alternatives. C C Taken from: C FITPACK - A Software Package for Curve and Surface Fitting C Employing Splines under Tension C by Alan Kaylor Cline, Department of Computer Sciences, C The University of Texas at Austin, August 31, 1981. C Note 1: C To conform with the FORTRAN77 standard, dummy array dimensions (1) C have been changed to (*), and subroutine TRISOL has been revised. C Note 2: C Subroutines CURVB1 and CURVBD do not belong to the original C version of FITPACK. C Note 3 C The lines denoted by '*V' in the first two columns of file C 'fit.for' calculate the model variations with respect to the model C parameters. C File 'fitv.for', intended for the model inversion, is created C from 'fit.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C Note 4: C To get the original versions of the subroutines SURFBD and VAL3BD, C the statement with 'CALL VAR2' must be removed from each of them. C The statements have been added by L.Klimes for the sake of inverse C modelling to the subroutines CURVBD, SURFBD, and VAL3BD. C The three appearances of the statements 'CALL VAR2' are denoted by C '*V' in the first 2 columns. The three lines should be removed or C modified before compilation. C C======================================================================= C C Part 0: C C======================================================================= C C C SUBROUTINE SNHCSH (SINHM,COSHM,X,ISW) C INTEGER ISW REAL SINHM,COSHM,X C C From FITPACK -- August 31, 1981 C Coded by A. K. Cline and R. J. Renka C Department of Computer Sciences C University of Texas at Austin C C This subroutine returns approximations to C SINHM(X) = SINH(X)-X C COSHM(X) = COSH(X)-1 C and C COSHMM(X) = COSH(X)-1-X*X/2 C with relative error less than 6.16e-6 C C On input-- C C X contains the value of the independent variable. C C ISW indicates the function desired C = -1 if only SINHM is desired, C = 0 if both SINHM and coshm are desired, C = 1 if only COSHM is desired, C = 2 if only COSHMM is desired, C = 3 if both SINHM and COSHMM are desired. C C On output-- C C SINHM contains the value of SINHM(X) if ISW .LE. 0 or C ISW .EQ. 3 (SINHM is unaltered if ISW .EQ.1 or ISW .EQ. C 2). C C COSHM contains the value of COSHM(X) if ISW .EQ. 0 or C ISW .EQ. 1 and contains the value of COSHMM(X) if ISW C .GE. 2 (COSHM is unaltered if ISW .EQ. -1). C C And C C X and ISW are unaltered. C C----------------------------------------------------------- C DATA SP2/5.04850926418006E-04/, * SP1/3.62841692246321E-02/, * SQ1/-1.37157937097122E-02/ DATA CP2/1.31625490355985E-03/, * CP1/6.57866547762733E-02/, * CQ1/-1.75465241841312E-02/ DATA ZP2/1.40048186158693E-04/, * ZP1/1.67309141907440E-02/, * ZQ2/9.82154460147143E-05/, * ZQ1/-1.66024148976133E-02/ XX = X AX = ABS(XX) XS = XX*XX IF ((AX .GE. 2.20) .OR. (AX .GE. 1.17 .AND. * ISW .NE. 2)) EXPX = EXP(AX) C C SINHM approximation C IF (ISW .EQ. 1 .OR. ISW .EQ. 2) GO TO 2 IF (AX .GE. 1.17) GO TO 1 SINHM = (((SP2*XS+SP1)*XS+1.)*XS*XX)/((SQ1*XS+1.)*6.) GO TO 2 1 SINHM = (EXPX-1./EXPX)/2.-AX IF (XX .LT. 0.) SINHM = -SINHM C C COSHM approximation C 2 IF (ISW .NE. 0 .AND. ISW .NE. 1) GO TO 4 IF (AX .GE. 1.17) GO TO 3 COSHM = (((CP2*XS+CP1)*XS+1.)*XS)/((CQ1*XS+1.)*2.) GO TO 4 3 COSHM = (EXPX+1./EXPX)/2.-1. C C COSHMM approximation C 4 IF (ISW .LE. 1) RETURN IF (AX .GE. 2.20) GO TO 5 COSHM = (((ZP2*XS+ZP1)*XS+1.)*XS*XS)/(((ZQ2*XS+ZQ1)*XS * +1.)*24.) RETURN 5 COSHM = (EXPX+1./EXPX)/2.-1.-XS/2. RETURN END C C======================================================================= C C Part 1: C C======================================================================= C C C SUBROUTINE CURVN1 (N,X,Y,YP,TEMP,SIGMA,IERR) C INTEGER N,IERR REAL X(N),Y(N),YP(N),TEMP(N),SIGMA C C From FITPACK -- August 31, 1981 C Coded by a. K. Cline and s. E. Galinsky C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines the parameters necessary to C compute a natural interpolatory spline under tension C through a sequence of functional values. For actual C computation of points on the curve it is necessary to call C the function CURV2. C C On input-- C C N is the number of values to be interpolated (N.GE.2). C C X is an array of the N increasing abscissae of the C functional values. C C Y is an array of the N ordinates of the values, (i. e. C Y(K) is the functional value corresponding to X(K) ). C C YP is an array of length at least N. C C TEMP is an array of length at least N which is used for C scratch storage. C C And C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e.g. .001) the resulting curve is approximately a C cubic spline. If ABS(SIGMA) is large (e.g. 50.) the C resulting curve is nearly a polygonal line. If SIGMA C equals zero a cubic spline results. A standard value C for SIGMA is approximately 1. In absolute value. C C On output-- C C YP contains the values of the second derivative of the C curve at the given nodes. C C IERR contains an error flag, C = 0 for normal return, C = 1 if N is less than 2, C = 2 if X-values are not strictly increasing. C C And C C N, X, Y, and SIGMA are unaltered. C C This subroutine references package modules SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 NP1 = N+1 IERR = 0 IF (N .LE. 1) GO TO 4 IF (X(N) .LE. X(1)) GO TO 5 C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Set up right hand side and tridiagonal system for YP and C perform forward elimination C DELX1 = X(2)-X(1) IF (DELX1 .LE. 0.) GO TO 5 DX1 = (Y(2)-Y(1))/DELX1 CALL TERMS (DIAG1,SDIAG1,SIGMAP,DELX1) SDIAG1 = 0. YP(1) = 0. TEMP(1) = 0. IF (N .EQ. 2) GO TO 2 DO 1 I = 2,NM1 DELX2 = X(I+1)-X(I) IF (DELX2 .LE. 0.) GO TO 5 DX2 = (Y(I+1)-Y(I))/DELX2 CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELX2) DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1) YP(I) = (DX2-DX1-SDIAG1*YP(I-1))/DIAG TEMP(I) = SDIAG2/DIAG DX1 = DX2 DIAG1 = DIAG2 1 SDIAG1 = SDIAG2 2 YP(N) = 0. TEMP(N-1) = 0. C C Perform back substitution C DO 3 I = 2,N IBAK = NP1-I 3 YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) RETURN C C Too few points C 4 IERR = 1 RETURN C C X-values not strictly increasing C 5 IERR = 2 RETURN END C C======================================================================= C C C SUBROUTINE CURVB1 (NX,X,W,C,VX,TEMP,SIGMA,IERR) C INTEGER NX,IERR REAL X(NX),W(NX),C(NX),VX(5,NX),TEMP(*),SIGMA C C Complement to FITPACK C by Alan Kaylor Cline C Coded -- October 9, 1986 C by Ludek Klimes C Inst. Geol. Geotechn. C Czechosl. Acad. Sci., Prague C C This subroutine determines the parameters necessary to C compute an interpolatory function on a one dimensional C grid. The function determined can be C represented by splines under tension. For actual C mapping of points it is necessary to call the subroutine C CURVBD, which also returns first and second derivatives. C C On input-- C C NX is the number of grid points. C (NX should be at least 2) C C X is array of the NX coordinates of the grid points. C These should be strictly increasing. C C W is an array of the NX functional values at the C the grid points, i. e. W(I,J) contains the functional C value at X(I) for I = 1,...,NX . C C C is an array of at least NX locations. This C parameter may coincide with W in which case W is C destroyed on output. C C VX is the array of at least 5 * NX locations. C C TEMP is an array of at least 3 * NX locations C which is used for scratch storage. C C SIGMA contains the tension factor. This value indicate C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the resulting surface is approximately the C tensor product of cubic splines. If ABS(SIGMA) is large C (e. g. 50.) the resulting surface is approximately C bi-linear. If SIGMA equals zero tensor products of cubic C splines result. A standard value for SIGMA is C approximately 1. In absolute value. C C On output-- C C C contains the coefficients of a representation of the C interpolated function in a B-spline form. C C VX contains B-spline under tension basis data. C C IERR contains an error flag. C = 0 for normal return, C = 1 if NX is less than 2, C = 2 if the X-array is not strictly C increasing. C C And C C None of the input parameters are altered (except W if C this parameter and C are identical in the calling C sequence). C C This subroutine references package modules VGEN, TERMS, C SNHCSH, TRIDEC, and TRISOL. C C----------------------------------------------------------- C C Copy W into C C DO 1 I = 1,NX 1 C(I) = W(I) C C Generate basis functions along X-grid C set up tridiagonal system and solve C CALL VGEN (NX,X,SIGMA,VX,IERR) IF (IERR .NE. 0) RETURN DO 2 I = 2,NX 2 TEMP(I) = VX(5,I-1) NXPI = NX DO 3 I = 1,NX NXPI = NXPI+1 3 TEMP(NXPI) = 1. DO 4 I = 2,NX NXPI = NXPI+1 4 TEMP(NXPI) = VX(4,I) CALL TRIDEC (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1), * TEMP(1),TEMP(NX+1),IERR) CALL TRISOL (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1),C,NX, * 1,1) RETURN END C C======================================================================= C C C SUBROUTINE SURFB1 (NX,NY,X,Y,W,NW1,C,VX,VY,TEMP,SIGMA, * IERR) C INTEGER NX,NY,NW1,IERR REAL X(NX),Y(NY),W(NW1,NY),C(NX,NY),VX(5,NX),VY(5,NY), * TEMP(*),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines the parameters necessary to C compute an interpolatory function on a two dimensional C rectangular grid. The function determined can be C represented as a tensor product of splines under tension C for actual mapping of points it is necessary to call the C subroutine SURFBD, which also returns first and second C partial derivatives. C C On input-- C C NX and NY are the number of grid lines in the X- and Y C directions, respectively, of the rectangular grid. (NX C and NY should be at least 2.) C C X and Y are arrays of the NX and NY coordinates of the C grid lines in X- and Y-directions, respectively. These C should be strictly increasing. C C W is an array of the NX * NY functional values at the C the grid points, i. e. W(I,J) contains the functional C value at (X(I),Y(J)) for I = 1,...,NX, and J = 1,...,NY. C C NW1 is the first dimension of the array W used in the C calling program (NW1 .GE. NX). C C C is an array of at least NX * NY locations. This C parameter may coincide with W in which case W is C destroyed on output. C C VX and VY are arrays of at least 5 * NX and 5 * NY C locations, respectively. C C Temp is an array of at least 3 * MAX(NX, NY) locations C which is used for scratch storage. C C And C C SIGMA contains the tension factor. This value indicate C the curviness desired. If ABS(SIGMA) is nearly zero C (e. G. .001) the resulting surface is approximately the C tensor product of cubic splines. If ABS(SIGMA) is large C (e. G. 50.) the resulting surface is approximately C bi-linear. If SIGMA equals zero tensor products of cubic C splines result. A standard value for SIGMA is C approximately 1. In absolute value. C C On output-- C C C contains the coefficients of a representation of the C interpolated function in a B-spline tensor production C form. C C VX and VY contain B-spline under tension basis data. C C IERR contains an error flag. C = 0 for normal return, C = 1 if NX or NY is less than 2, C = 2 if the X- or Y-arrays are not strictly C increasing. C C And C C None of the input parameters are altered (except W if C this parameter and C are identical in the calling C sequence). C C This subroutine references package modules VGEN, TERMS, C SNHCSH, TRIDEC, and TRISOL. C C--------------------------------------------------------- - C C Copy W into C C DO 1 J = 1,NY DO 1 I = 1,NX 1 C(I,J) = W(I,J) C C Generate basis functions along X-grid C set up tridiagonal system and solve C CALL VGEN (NX,X,SIGMA,VX,IERR) IF (IERR .NE. 0) RETURN DO 2 I = 2,NX 2 TEMP(I) = VX(5,I-1) NXPI = NX DO 3 I = 1,NX NXPI = NXPI+1 3 TEMP(NXPI) = 1. DO 4 I = 2,NX NXPI = NXPI+1 4 TEMP(NXPI) = VX(4,I) CALL TRIDEC (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1), * TEMP(1),TEMP(NX+1),IERR) CALL TRISOL (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1),C,NX, * NY,1) C C Generate basis functions along Y-grid C set up tridiagonal system and solve C CALL VGEN (NY,Y,SIGMA,VY,IERR) IF (IERR .NE. 0) RETURN DO 5 J = 2,NY 5 TEMP(J) = VY(5,J-1) NYPJ = NY DO 6 J = 1,NY NYPJ = NYPJ+1 6 TEMP(NYPJ) = 1. DO 7 J = 2,NY NYPJ = NYPJ+1 7 TEMP(NYPJ) = VY(4,J) CALL TRIDEC (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1), * TEMP(1),TEMP(NY+1),IERR) CALL TRISOL (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1),C,1, * NX,NX) RETURN END C C======================================================================= C C C SUBROUTINE VAL3B1 (NX,NY,NZ,X,Y,Z,W,NW1,NW2,C,VX,VY, * VZ,TEMP,SIGMA,IERR) C INTEGER NX,NY,NZ,NW1,NW2,IERR REAL X(NX),Y(NY),Z(NZ),W(NW1,NW2,NZ),C(NX,NY,NZ), * VX(5,NX),VY(5,NY),VZ(5,NZ),TEMP(*),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines the parameters necessary to C compute an interpolatory function on a three dimensional C rectangular grid. The function determined can be C represented as a tensor product of splines under tension. C For actual mapping of points it is necessary to call the C subroutine VAL3BD, which also returns first and second C partial derivatives. C C On input-- C C NX, NY, and NZ are the number of grid lines in the X-, C Y-, and Z-directions, respectively, of the rectangular C grid. (NX, NY, and NZ should be at least 2.) C C X, Y, and Z are arrays of the NX, NY, and NZ coordinates C of the grid lines in the X-, Y-, and Z-directions, C respectively. These should be strictly increasing. C C W is an array of the NX * NY * NZ functional values at C the grid points, i. e. W(I,J,K) contains the functional C value at (X(I),Y(J),Z(K)) for I = 1,...,NX, C J = 1,...,NY, and K = 1,...,NZ. C C NW1 and NW2 are the first two dimensions of the array W C used in the calling program (NW1 .GE. NX AND NW2 .GE. C NY). C C C is an array of at least NX * NY * NZ locations. This C parameter may coincide with W in which case W is C destroyed on output. C C VX, VY, and VZ are arrays of at least 5 * NX, 5 * NY, C and 5 * NZ locations, respectively. C C Temp is an array of at least 3 * MAX(NX, NY, NZ) C locations which is used for scratch storage. C C And C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the resulting surface is approximately the C tensor product of cubic splines. If ABS(SIGMA) is large C (e. g. 50.) the resulting surface is approximately C tri-linear. If SIGMA equals zero tensor products of C cubic splines result. A standard value for SIGMA is C approximately 1. In absolute value. C C On output-- C C C contains the coefficients of a representation of the C interpolated function in a B-spline tensor production C form. C C VX, VY, and VZ contain B-spline under tension basis C data. C C IERR contains an error flag. C = 0 for normal return, C = 1 if NX, NY, or NZ is less than 2, C = 2 if the X-, Y-, or Z-arrays are not strictly C increasing. C C And C C None of the input parameters are altered (except W if C this parameter and C are identical in the calling C sequence). C C This subroutine references package modules VGEN, TERMS, C SNHCSH, TRIDEC, and TRISOL. C C----------------------------------------------------------- C C Copy W into C C DO 1 K = 1,NZ DO 1 J = 1,NY DO 1 I = 1,NX 1 C(I,J,K) = W(I,J,K) C C Generate basis functions along X-grid C set up tridiagonal system and solve C CALL VGEN (NX,X,SIGMA,VX,IERR) IF (IERR .NE. 0) RETURN DO 2 I = 2,NX 2 TEMP(I) = VX(5,I-1) NXPI = NX DO 3 I = 1,NX NXPI = NXPI+1 3 TEMP(NXPI) = 1. DO 4 I = 2,NX NXPI = NXPI+1 4 TEMP(NXPI) = VX(4,I) CALL TRIDEC (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1), * TEMP(1),TEMP(NX+1),IERR) CALL TRISOL (NX,TEMP(1),TEMP(NX+1),TEMP(2*NX+1),C,NX, * NY*NZ,1) C C Generate basis functions along Y-grid C set up tridiagonal system and solve C CALL VGEN (NY,Y,SIGMA,VY,IERR) IF (IERR .NE. 0) RETURN DO 5 J = 2,NY 5 TEMP(J) = VY(5,J-1) NYPJ = NY DO 6 J = 1,NY NYPJ = NYPJ+1 6 TEMP(NYPJ) = 1. DO 7 J = 2,NY NYPJ = NYPJ+1 7 TEMP(NYPJ) = VY(4,J) CALL TRIDEC (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1), * TEMP(1),TEMP(NY+1),IERR) DO 8 K = 1,NZ 8 CALL TRISOL (NY,TEMP(1),TEMP(NY+1),TEMP(2*NY+1),C(1,1,K), * 1,NX,NX) C C Generate basis functions along Z-grid C set up tridiagonal system and solve C CALL VGEN (NZ,Z,SIGMA,VZ,IERR) IF (IERR .NE. 0) RETURN DO 9 K = 2,NZ 9 TEMP(K) = VZ(5,K-1) NZPK = NZ DO 10 K = 1,NZ NZPK = NZPK+1 10 TEMP(NZPK) = 1. DO 11 K = 2,NZ NZPK = NZPK+1 11 TEMP(NZPK) = VZ(4,K) CALL TRIDEC (NZ,TEMP(1),TEMP(NZ+1),TEMP(2*NZ+1), * TEMP(1),TEMP(NZ+1),IERR) CALL TRISOL (NZ,TEMP(1),TEMP(NZ+1),TEMP(2*NZ+1),C,1, * NX*NY,NX*NY) RETURN END C C======================================================================= C C C SUBROUTINE VGEN (N,X,SIGMA,V,IERR) C INTEGER N,IERR REAL X(N),SIGMA,V(5,N) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine generates an array of coefficients used by C other subroutines for the determination of a B-spline C under tension basis. C C On input-- C C N is the number of knots defining the basis (N .GE. 2). C C X is the array of the N increasing knots. Any linear C combination of the resulting basis will have third C derivative discontinuities only at the interior knots, C (i. e. X(2),...,X(N-1) ). C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the basis functions are approximately cubic C splines. If ABS(SIGMA) is large (e. g. 50.) the basis C functions are nearly piecewise linear. If SIGMA equals C zero a cubic spline basis results. A standard value for C SIGMA is approximately 1. In absolute value. C C And C C V is an array of at least 5*N locations. C C On output-- C C V contains certain coefficients to be used by other C subprograms for the determination of the B-spline under C tension basis. Considered as a 5 by N array, for I = 1, C ... , N, B-spline basis function I is specified by-- C V(1,I) = second derivative at X(I-1), for I .NE. 1, C V(2,I) = second derivative at X(I), for all I, C V(3,I) = second derivative at X(I+1), for I .NE. N, C V(4,I) = function value at X(I-1), for I .NE. 1, C V(5,I) = function value at X(I+1), for I .NE. N, C and the properties that it has-- C 1. Function value 1 at X(I), C 2. Function value and second derivative = 0 at C X(1), ... , X(I-2), and X(I+2), ... , X(N). C In V(5,N) and V(3,N) are contained function value and C second derivative of basis function zero at X(1), C respectively. In V(4,1) and V(1,1) are contained C function value and second derivative of basis function C N+1 at X(N), respectively. Function value and second C derivative of these two basis functions are zero at all C other knots. Only basis function zero has non-zero C second derivative value at X(1) and only basis C function N+1 has non-zero second derivative at X(N). C C IERR contains an error flag, C = 0 for normal return, C = 1 if N is less than 2, C = 2 if X-values are not strictly increasing. C C And C C N, X, and SIGMA are unaltered. C C This subroutine references package modules TERMS and C SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 IERR = 0 IF (N .LE. 1) GO TO 3 IF (X(N) .LE. X(1)) GO TO 4 C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Generate coefficients for left end basis functions C D3 = X(2)-X(1) IF (D3 .LE. 0.) GO TO 4 CALL TERMS (DIAG3,SDIAG3,SIGMAP,D3) D4 = D3 IF (N .GE. 3) D4 = X(3)-X(2) IF (D4 .LE. 0.) GO TO 4 CALL TERMS (DIAG4,SDIAG4,SIGMAP,D4) A22 = DIAG3+SDIAG3 A23 = DIAG3+DIAG4+SDIAG3+SDIAG4 V(2,1) = 0. V(3,1) = 1./(D3*(DIAG3+DIAG4)+(D3+D4)*SDIAG4) V(5,1) = SDIAG4*D4*V(3,1) IF (N .EQ. 2) GO TO 2 A22 = 2.*A22 D1 = D3 D2 = D3 D3 = D4 DIAG1 = DIAG3 DIAG2 = DIAG3 DIAG3 = DIAG4 SDIAG1 = SDIAG3 SDIAG2 = SDIAG3 SDIAG3 = SDIAG4 C C Generate coefficients for interior basis functions C DO 1 I = 2,NM1 IF (I .NE. NM1) D4 = X(I+2)-X(I+1) IF (D4 .LE. 0.) GO TO 4 IF (D4 .NE. D3) CALL TERMS (DIAG4,SDIAG4,SIGMAP,D4) A11 = DIAG1+DIAG2+SDIAG1*(1.+D1/D2) A12 = SDIAG2/A11 B1 = 1./(D2*A11) A33 = DIAG3+DIAG4+SDIAG4*(1.+D4/D3) A32 = SDIAG3/A33 B3 = 1./(D3*A33) A21 = A22 A22 = A23 A23 = DIAG3+DIAG4+SDIAG3+SDIAG4 V(2,I) = -(A21*B1+A23*B3)/(A22-A21*A12-A23*A32) V(1,I) = B1-A12*V(2,I) V(3,I) = B3-A32*V(2,I) V(4,I) = SDIAG1*D1*V(1,I) V(5,I) = SDIAG4*D4*V(3,I) C C Save constants for next iteration C D1 = D2 D2 = D3 D3 = D4 DIAG1 = DIAG2 DIAG2 = DIAG3 DIAG3 = DIAG4 SDIAG1 = SDIAG2 SDIAG2 = SDIAG3 1 SDIAG3 = SDIAG4 C C Generate coefficients for right end basis functions C V(2,N) = 0. V(1,N) = 1./(D2*(DIAG1+DIAG2)+(D2+D1)*SDIAG1) V(4,N) = SDIAG1*D1*V(1,N) V(3,N) = V(1,3) V(5,N) = V(4,3) V(1,1) = V(3,N-2) V(4,1) = V(5,N-2) C C Adjust basis for natural end conditions C V(4,2) = V(4,2)-V(1,2)*V(5,N)/V(3,N) V(1,2) = 0. V(5,NM1) = V(5,NM1)-V(3,NM1)*V(4,1)/V(1,1) V(3,NM1) = 0. RETURN C C N equal to 2 C 2 V(4,1) = V(5,1) V(1,1) = V(3,1) V(3,1) = 0. V(5,1) = 0. V(1,2) = 0. V(2,2) = 0. V(3,2) = V(1,1) V(4,2) = 0. V(5,2) = V(4,1) RETURN C C Too few knots C 3 IERR = 1 RETURN C C X-values not strictly increasing C 4 IERR = 2 RETURN END C C======================================================================= C C C SUBROUTINE TERMS (DIAG,SDIAG,SIGMA,DEL) C REAL DIAG,SDIAG,SIGMA,DEL C C From FITPACK -- August 31, 1981 C Coded by A. K. Cline and R. J. Renka C Department of Computer Sciences C University of Texas at Austin C C This subroutine computes the diagonal and superdiagonal C terms of the tridiagonal linear system associated with C spline under tension interpolation. C C On input-- C C SIGMA contains the tension factor. C C And C C DEL contains the step size. C C On output-- C C (SIGMA*DEL*COSH(SIGMA*DEL) - SINH(SIGMA*DEL) C DIAG = DEL*--------------------------------------------. C (SIGMA*DEL)**2 * SINH(SIGMA*DEL) C C SINH(SIGMA*DEL) - SIGMA*DEL C SDIAG = DEL*----------------------------------. C (SIGMA*DEL)**2 * SINH(SIGMA*DEL) C C And C C SIGMA and DEL are unaltered. C C This subroutine references package module SNHCSH. C C----------------------------------------------------------- C IF (SIGMA .NE. 0.) GO TO 1 DIAG = DEL/3. SDIAG = DEL/6. RETURN 1 SIGDEL = SIGMA*DEL CALL SNHCSH (SINHM,COSHM,SIGDEL,0) DENOM = DEL/((SINHM+SIGDEL)*SIGDEL*SIGDEL) DIAG = DENOM*(SIGDEL*COSHM-SINHM) SDIAG = DENOM*SINHM RETURN END C C======================================================================= C C C SUBROUTINE TRIDEC (N,SUBDI,DIAGI,SUPD,SUBDO,DIAGO, * IERR) C INTEGER N,IERR REAL SUBDI(N),DIAGI(N),SUPD(N),SUBDO(N),DIAGO(N) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine factorizes a tridiagonal matrix in order C to solve systems of linear equations. The factorization C employs gaussian elimination without any interchanging of C columns or rows. The subroutine trisol may be called to C actually solve the system once the factorization has been C performed. C C On input-- C C N contains the order of the matrix (N .GE. 1). C C SUBDI is an array containing the subdiagonal elements of C the matrix in positions 2, ... , N. C C DIAGI is an array containing the diagonal elements of C the matrix. C C SUPD is an array containing the superdiagonal elements C of the matrix in positions 1, ... , N-1. C C And C C SUBDO and DIAGO are arrays of length N. (The storage C for these may coincide with that for SUBDI and DIAGI, C respectively, in which case the original contents of C SUBDI and DIAGI will be destroyed.) C C On output-- C C SUBDO and DIAGO contain the subdiagonal and diagonal of C the factorization matrix. C C IERR contains an error flag, C = 0 for normal return, C = 1 if N is less than 1, C = 2 if the system is singular. C C And C C N, SUBDI, DIAGI, and SUPD are unaltered (unless storage C for SUBDI or DIAGI coincided with that for SUBDO C or DIAGO, respectively). C C----------------------------------------------------------- C IF (N .LE. 0) GO TO 3 IERR = 2 DIAGO(1) = DIAGI(1) IF (N .EQ. 1) GO TO 2 C C Forward elimination C DO 1 I = 2,N IM1 = I-1 IF (DIAGO(IM1) .EQ. 0.) RETURN DIAGO(IM1) = 1./DIAGO(IM1) SUBDO(I) = SUBDI(I)*DIAGO(IM1) 1 DIAGO(I) = DIAGI(I)-SUBDO(I)*SUPD(IM1) 2 IF (DIAGO(N) .EQ. 0.) RETURN DIAGO(N) = 1./DIAGO(N) IERR = 0 RETURN C C N less than 1 C 3 IERR = 1 RETURN END C C======================================================================= C C C SUBROUTINE TRISOL (N,SUBD,DIAG,SUPD,RHS,MRHS,NUMRHS, * INCRHS) C INTEGER N,MRHS,NUMRHS,INCRHS REAL SUBD(N),DIAG(N),SUPD(N) REAL RHS(1+INCRHS*(N-1)+MRHS*(NUMRHS-1)) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C Revised -- December 31, 1992 C by Ludek Klimes C Institute of Geotechnics C Czechosl. Acad. Sci., Prague C C This subroutine solves tridiagonal systems of linear C equations with multiple right hand sides. The right hand C sides may be stored row-wise or column-wise. The C subroutine TRIDEC should be called earlier to determine a C factorization of the tridiagonal matrix. The solution C vectors over-write the right hand sides. C C On input-- C C N contains the order of the matrix (N .GE. 1). C C SUBD, DIAG, and SUPD are arrays of length N containing C the subdiagonal, diagonal, and superdiagonal of the C factorization, respectively. C C RHS is an array containing the right hand sides of the C tridiagonal system. C C MRHS is the increment between the first components of C each of the right hand side vectors in storage (MRHS C .GE. 1). C C NUMRHS is the number of right hand sides to be solved. C C And C C INCRHS is the increment between components within each C of the right hand side vectors in storage (INCRHS .GE. C 1). C C The parameters N, SUBD, DIAG, and SUPD may be input as the C parameters N, SUBDO, DIAGO, and SUPD output by subroutine C TRIDEC, respectively. C C On output-- C C RHS contains the solution vectors in the same storage C structure as for the right hand sides. C C And C C N, SUBD, DIAG, SUPD, MRHS, NUMRHS, and INCRHS are C unaltered. C C----------------------------------------------------------- C NP1 = N+1 C C Loop on right hand sides C DO 4 K = 1,NUMRHS C C Forward elimination C IRHS = 1+MRHS*(K-1) IF (N .EQ. 1) GO TO 2 DO 1 I = 2,N IM1RHS = IRHS IRHS = IRHS+INCRHS 1 RHS(IRHS) = RHS(IRHS)-SUBD(I)*RHS(IM1RHS) C C Back substitution C 2 RHS(IRHS) = DIAG(N)*RHS(IRHS) IF (N .EQ. 1) GO TO 4 DO 3 IBAK = 2,N I = NP1-IBAK RHS(IM1RHS) = DIAG(I)*(RHS(IM1RHS)-SUPD(I) * *RHS(IRHS)) IRHS = IM1RHS 3 IM1RHS = IM1RHS-INCRHS 4 CONTINUE RETURN END C C======================================================================= C C Part 2: C C======================================================================= C C C SUBROUTINE CURV2D (T,YY,YX,YXX,N,X,Y,YP,SIGMA) C INTEGER N REAL T,YY,YX,YXX,X(N),Y(N),YP(N),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine determines function value, first, and C second derivatives of a curve at a given point using a C spline under tension. The subroutine CURV1 should be C called earlier to determine certain necessary parameters. C C On input-- C C T contains a real value at which the function and C derivatives are to be evaluated. C C N contains the number of points which were specified to C determine the curve. C C X and Y are arrays containing the abscissae and C ordinates, respectively, of the specified points. C C YP is an array of second derivative values of the curve C at the nodes. C C And C C SIGMA contains the tension factor (its sign is ignored). C C The parameters N, X, Y, YP, and SIGMA should be input C unaltered from the output of CURV1. C C On output-- C C YY, YX, and YXX contain the function value, first and C second derivatives, respectively. C C None of the input parameters are altered. C C This subroutine references package modules INTRVL and C SNHCSH. C C----------------------------------------------------------- C C Determine interval C IM1 = INTRVL(T,X,N) I = IM1+1 C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Set up and perform interpolation C DEL1 = T-X(IM1) DEL2 = X(I)-T DELS = X(I)-X(IM1) YY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS YX = (Y(I)-Y(IM1))/DELS IF (SIGMAP .NE. 0.) GO TO 1 YY = YY-DEL1*DEL2*(YP(I)*(DEL1+DELS)+YP(IM1)* * (DEL2+DELS))/(6.*DELS) YX = YX+(YP(I)*(2.*DEL1*DEL1-DEL2*(DEL1+DELS))- * YP(IM1)*(2.*DEL2*DEL2-DEL1*(DEL2+DELS))) * /(6.*DELS) YXX = (YP(I)*DEL1+YP(IM1)*DEL2)/DELS RETURN 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH (SINHM1,COSHM1,SIGMAP*DEL1,0) CALL SNHCSH (SINHM2,COSHM2,SIGMAP*DEL2,0) CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) YY = YY+(YP(I)*(SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)* * SINHP2+SIGMAP*COSHP1*DEL2))+YP(IM1)*(SINHM2* * DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP* * COSHP2*DEL1)))/(SIGMAP*SIGMAP*DELS*(SINHMS+ * SIGMAP*DELS)) YX = YX+(YP(I)*(DELS*SIGMAP*COSHM1-SINHMS)- * YP(IM1)*(DELS*SIGMAP*COSHM2-SINHMS))/ * (SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)) YXX = (YP(I)*(SINHM1+SIGMAP*DEL1)+YP(IM1)*(SINHM2+ * SIGMAP*DEL2))/(SINHMS+SIGMAP*DELS) RETURN END C C======================================================================= C C C SUBROUTINE CURVBD (XX,W,WX,WXX,NX,X,C,VX,SIGMA) C INTEGER NX REAL XX,W,WX,WXX,X(NX),VX(5,NX),C(NX),SIGMA C C Complement to FITPACK C by Alan Kaylor Cline C Coded -- October 9, 1986 C by Ludek Klimes C Inst. Geol. Geotechn. C Czechosl. Acad. Sci., Prague C C This subroutine evaluates the function value, the C first partial derivative, and the second partial C derivative of a spline under tension in one variable. C C On input-- C C XX contains the X-coordinate of the point C at which the interpolation is to be performed C C NX is the number of grid points C C X is array containing the X-grid values. C C C is an array of coefficients describing the function in C terms of a B-spline under tension basis. In the C expansion of the function, for I = 1,...,NX , C the coefficient multiplying the basis C function I is stored in C(I). C C VX is the array of length 5*NX C containing the B-spline basis data C C SIGMA contains the tension factor (its sign is ignored). C C The parameters NX, X, C, VX, and SIGMA C should be input unaltered from the output of CURVB1. C C On output-- C C W contains the interpolated function value. C C WX contains the first derivative . C C WXX contains the second derivative . C C And C C None of the input parameters are altered. C C This subroutine references package modules DSPLNZ, INTRVL, C and SNHCSH. C C-------------------------------------------------------------- C REAL BX(3,4) C C Evaluate basis functions at XX C CALL DSPLNZ (XX,NX,X,VX,SIGMA,ISTART,BX) C C Accumulate basis functions C SUM = 0. SUMX = 0. SUMXX = 0. DO 1 I = 1,4 II = ISTART+I-1 IF (II .EQ. 0 .OR. II .GT. NX) GO TO 1 BX1I = BX(1,I) CI = C(II) SUM = SUM+CI*BX1I SUMX = SUMX+CI*BX(2,I) SUMXX = SUMXX+CI*BX(3,I) CALL VAR2(II,BX1I,BX(2,I),0.,0.) 1 CONTINUE W = SUM WX = SUMX WXX = SUMXX RETURN END C C======================================================================= C C C SUBROUTINE SURFBD (XX,YY,W,WX,WY,WXX,WXY,WYY,NX,NY,X, * Y,C,VX,VY,SIGMA) C INTEGER NX,NY REAL XX,YY,W,WX,WY,WXX,WXY,WYY,X(NX),Y(NY),VX(5,NX), * VY(5,NY),C(NX,NY),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine evaluates the function value, the two C first partial derivatives, and the six second partial C derivatives of a tensor product spline under tension in C two variables. C C On input-- C C XX and YY contain the X- and Y-coordinates of the point C at which the interpolation is to be performed. C C NX and NY are the number of grid lines in the X- and Y- C directions, respectively, of the rectangular grid which C specified the function. C C X and Y are arrays containing the X- and Y-grid values, C respectively. C C C is an array of coefficients describing the function in C terms of a B-spline under tension basis. In the C expansion of the function, for I = 1,...,NX and J = 1, C ...,NY, the coefficient multiplying the product of basis C function I in X and basis function J in Y is stored in C C(I,J). C C VX and VY VZ are arrays of length 5*NX and 5*NY, C respectively, containing the B-spline basis data for the C X- and Y-grids. C C And C C SIGMA contains the tension factor (its sign is ignored). C C The parameters NX, NY, X, Y, Z, C, VX, VY, and SIGMA C should be input unaltered from the output of SURFB1. C C On output-- C C W contains the interpolated function value. C C WX and WY contain the X- and Y-partial derivatives, C respectively. C C WXX, WXY, and WYY contain the XX-, XY-, and YY-partial C derivatives, respectively. C C And C C None of the input parameters are altered. C C This subroutine references package modules DSPLNZ, INTRVL, C and SNHCSH. C C--------------------------------------------------------- ---- C REAL BX(3,4),BY(3,4) C C Evaluate basis functions at XX and YY C CALL DSPLNZ (XX,NX,X,VX,SIGMA,ISTART,BX) CALL DSPLNZ (YY,NY,Y,VY,SIGMA,JSTART,BY) C C Accumulate tensor products C SUM = 0. SUMX = 0. SUMY = 0. SUMXX = 0. SUMXY = 0. SUMYY = 0. DO 2 J = 1,4 JJ = JSTART+J-1 IF (JJ .EQ. 0 .OR. JJ .GT. NY) GO TO 2 BY1J = BY(1,J) BY2J = BY(2,J) BY3J = BY(3,J) DO 1 I = 1,4 II = ISTART+I-1 IF (II .EQ. 0 .OR. II .GT. NX) GO TO 1 BX1I = BX(1,I) BX2I = BX(2,I) CIJ = C(II,JJ) SUM = SUM+CIJ*BX1I*BY1J SUMX = SUMX+CIJ*BX2I*BY1J SUMY = SUMY+CIJ*BX1I*BY2J SUMXX = SUMXX+CIJ*BX(3,I)*BY1J SUMXY = SUMXY+CIJ*BX2I*BY2J SUMYY = SUMYY+CIJ*BX1I*BY3J CALL VAR2(II+NX*(JJ-1),BX1I*BY1J,BX2I*BY1J,BX1I*BY2J,0.) 1 CONTINUE 2 CONTINUE W = SUM WX = SUMX WY = SUMY WXX = SUMXX WXY = SUMXY WYY = SUMYY RETURN END C C======================================================================= C C C SUBROUTINE VAL3BD (XX,YY,ZZ,W,WX,WY,WZ,WXX,WXY,WYY, * WYZ,WZZ,WXZ,NX,NY,NZ,X,Y,Z,C,VX,VY, * VZ,SIGMA) C INTEGER NX,NY,NZ REAL XX,YY,ZZ,W,WX,WY,WZ,WXX,WXY,WYY,WYZ,WZZ,WXZ, * X(NX),Y(NY),Z(NZ),VX(5,NX),VY(5,NY),VZ(5,NZ), * C(NX,NY,NZ),SIGMA C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine evaluates the function value, the three C first partial derivatives, and the six second partial C derivatives of a tensor product spline under tension in C three variables. C C On input-- C C XX, YY, and ZZ contain the X-, Y-, and Z-coordinates of C the point at which the interpolation is to be performed. C C NX, NY, and NZ are the number of grid lines in the X-, C Y-, and Z-directions, respectively, of the rectangular C grid which specified the function. C C X, Y, and Z are arrays containing the X-, Y-, and Z-grid C values, respectively. C C C is an array of coefficients describing the function in C terms of a B-spline under tension basis. In the C expansion of the function, for I = 1,...,NX, J = 1,..., C NY, AND K = 1,...,NZ, the coefficient multiplying the C product of basis function I in X, basis function J in Y, C and basis function K in Z is stored in C(I,J,K). C C VX, VY, and VZ are arrays of length 5*NX, 5*NY, and C 5*NZ, respectively, containing the B-spline basis data C for the X-, Y-, and Z-grids. C C And C C SIGMA contains the tension factor (its sign is ignored). C C The parameters NX, NY, NZ, X, Y, Z, C, VX, VY, VZ, and C SIGMA should be input unaltered from the output of C VAL3B1. C C On output-- C C W contains the interpolated function value. C C WX, WY, and WZ contain the X-, Y-, and Z-partial C derivatives, respectively. C C WXX, WXY, WYY, WYZ, WZZ, and WXZ contain the XX-, XY- C YY-, YZ-, ZZ-, and XZ-partial derivatives, respectively. C C And C C None of the input parameters are altered. C C This subroutine references package modules DSPLNZ, INTRVL, C and SNHCSH. C C-------------------------------------------------------------- C REAL BX(3,4),BY(3,4),BZ(3,4) C C Evaluate basis functions at XX, YY, and ZZ C CALL DSPLNZ (XX,NX,X,VX,SIGMA,ISTART,BX) CALL DSPLNZ (YY,NY,Y,VY,SIGMA,JSTART,BY) CALL DSPLNZ (ZZ,NZ,Z,VZ,SIGMA,KSTART,BZ) C C Accumulate tensor products C SUM = 0. SUMX = 0. SUMY = 0. SUMZ = 0. SUMXX = 0. SUMXY = 0. SUMYY = 0. SUMYZ = 0. SUMZZ = 0. SUMXZ = 0. DO 3 K = 1,4 KK = KSTART+K-1 IF (KK .EQ. 0 .OR. KK .GT. NZ) GO TO 3 BZ1K = BZ(1,K) BZ2K = BZ(2,K) BZ3K = BZ(3,K) DO 2 J = 1,4 JJ = JSTART+J-1 IF (JJ .EQ. 0 .OR. JJ .GT. NY) GO TO 2 BY1J = BY(1,J) BY2J = BY(2,J) BY3J = BY(3,J) DO 1 I = 1,4 II = ISTART+I-1 IF (II .EQ. 0 .OR. II .GT. NX) GO TO 1 BX1I = BX(1,I) BX2I = BX(2,I) CIJK = C(II,JJ,KK) SUM = SUM+CIJK*BX1I*BY1J*BZ1K SUMX = SUMX+CIJK*BX2I*BY1J*BZ1K SUMY = SUMY+CIJK*BX1I*BY2J*BZ1K SUMZ = SUMZ+CIJK*BX1I*BY1J*BZ2K SUMXX = SUMXX+CIJK*BX(3,I)*BY1J*BZ1K SUMXY = SUMXY+CIJK*BX2I*BY2J*BZ1K SUMYY = SUMYY+CIJK*BX1I*BY3J*BZ1K SUMYZ = SUMYZ+CIJK*BX1I*BY2J*BZ2K SUMZZ = SUMZZ+CIJK*BX1I*BY1J*BZ3K SUMXZ = SUMXZ+CIJK*BX2I*BY1J*BZ2K CALL VAR2(II+NX*(JJ-1+NY*(KK-1)),BX1I*BY1J*BZ1K, * BX2I*BY1J*BZ1K,BX1I*BY2J*BZ1K,BX1I*BY1J*BZ2K) 1 CONTINUE 2 CONTINUE 3 CONTINUE W = SUM WX = SUMX WY = SUMY WZ = SUMZ WXX = SUMXX WXY = SUMXY WYY = SUMYY WYZ = SUMYZ WZZ = SUMZZ WXZ = SUMXZ RETURN END C C======================================================================= C C C SUBROUTINE DSPLNZ (T,N,X,V,SIGMA,ISTART,B) C INTEGER N,ISTART REAL T,X(N),V(5,N),SIGMA,B(3,4) C C From FITPACK -- August 31, 1981 C Coded by Alan Kaylor Cline C Department of Computer Sciences C University of Texas at Austin C C This subroutine evaluates at a given point the four non- C zero basis functions of a B-spline under tension basis and C their first and second derivatives. The index of the first C non-zero basis function is also determined. (the sense of C the word non-zero is extended to include the special case C where the given point coincides with a knot in which case C the last of the four returned function values may be zero. C ) the subroutine VGEN should be called earlier to C determine certain necessary coefficients. C C On input-- C C T contains a real value at which the basis functions are C to be evaluated. C C N contains the number of knots defining the basis. C C X contains the array of knots. C C V contains the array of coefficients determined by VGEN C for calculation of basis functions. C C SIGMA contains the tension factor (its sign is ignored). C C ISTART is an integer variable. C C And C C B is a real array with 3 rows and 4 columns. C C The parameters N, X, V, and SIGMA should be input C unaltered from the output of VGEN. C C On output-- C C ISTART contains the index of the first non-zero basis C function. Thus 0 .LE. ISTART .LE. N-2 and the non-zero C basis functions have indices ISTART, ... , ISTART+3. C C B contains the values at T of basis functions ISTART, C ... , ISTART+3 in B(1,1), ... , B(1,4), respectively. C First and second derivatives of the corresponding C functions are contained in B(2,1), ... , B(2,4), and C B(3,1), ... , B(3,4), respectively. C C T, N, X, V, and SIGMA are unaltered. C C This subroutine references package modules INTRVL and C SNHCSH. C C----------------------------------------------------------- C C Denormalize tension factor C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C Determine index of first non-zero basis function C I = INTRVL (T,X,N)-1 C C Compute distances to adjacent knots and lagrangian C weights C DEL1 = T-X(I+1) DEL2 = X(I+2)-T DELS = X(I+2)-X(I+1) C10 = DEL2/DELS C20 = DEL1/DELS C11 = -1./DELS C21 = 1./DELS IF (SIGMAP .NE. 0.) GO TO 1 FAC = -DEL1*DEL2/(6.*DELS) CP10 = FAC*(DEL2+DELS) CP20 = FAC*(DEL1+DELS) CP11 = -(2.*DEL2*DEL2-DEL1*(DEL2+DELS))/(6.*DELS) CP21 = (2.*DEL1*DEL1-DEL2*(DEL1+DELS))/(6.*DELS) CP12 = C10 CP22 = C20 GO TO 2 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH (SINHM1,COSHM1,SIGMAP*DEL1,0) CALL SNHCSH (SINHM2,COSHM2,SIGMAP*DEL2,0) CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) SINHS = SINHMS+SIGMAP*DELS DENOM = SIGMAP*SIGMAP*DELS*SINHS CP10 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1 * +SIGMAP*COSHP2*DEL1))/DENOM CP20 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2 * +SIGMAP*COSHP1*DEL2))/DENOM CP11 = -(DELS*SIGMAP*COSHM2-SINHMS)/DENOM CP21 = (DELS*SIGMAP*COSHM1-SINHMS)/DENOM CP12 = (SINHM2+SIGMAP*DEL2)/SINHS CP22 = (SINHM1+SIGMAP*DEL1)/SINHS C C Compute basis function values C 2 II = I IF (II .EQ. 0) II = N IIP1 = I+1 IIP2 = I+2 IIP3 = I+3 IF (IIP2 .EQ. N) IIP3 = 1 B(1,1) = C10*V(5,II)+CP10*V(3,II) B(1,2) = C10+C20*V(5,IIP1)+CP10*V(2,IIP1)+ * CP20*V(3,IIP1) B(1,3) = C10*V(4,IIP2)+C20+CP10*V(1,IIP2)+ * CP20*V(2,IIP2) B(1,4) = C20*V(4,IIP3)+CP20*V(1,IIP3) B(2,1) = C11*V(5,II)+CP11*V(3,II) B(2,2) = C11+C21*V(5,IIP1)+CP11*V(2,IIP1)+ * CP21*V(3,IIP1) B(2,3) = C11*V(4,IIP2)+C21+CP11*V(1,IIP2)+ * CP21*V(2,IIP2) B(2,4) = C21*V(4,IIP3)+CP21*V(1,IIP3) B(3,1) = CP12*V(3,II) B(3,2) = CP12*V(2,IIP1)+CP22*V(3,IIP1) B(3,3) = CP12*V(1,IIP2)+CP22*V(2,IIP2) B(3,4) = CP22*V(1,IIP3) ISTART = I RETURN END C C======================================================================= C C C FUNCTION INTRVL (T,X,N) C INTEGER N REAL T,X(N) C C From FITPACK -- August 31, 1981 C Coded by A. K. Cline and R. J. Renka C Department of Computer Sciences C University of Texas at Austin C C This function determines the index of the interval C (determined by a given increasing sequence) in which C a given value lies. C C On input-- C C T is the given value. C C X is a vector of strictly increasing values. C C And C C N is the length of X (N .GE. 2). C C On output-- C C INTRVL returns an integer I such that C C I = 1 if T .LT. X(2) , C I = N-1 if X(N-1) .LE. T , C otherwise X(I) .LE. T .LT. X(I+1), C C None of the input parameters are altered. C C----------------------------------------------------------- C TT = T IF (TT .LT. X(2)) GO TO 4 IF (TT .GE. X(N-1)) GO TO 5 IL = 2 IH = N-1 C C Linear interpolation C 1 I = MIN0(IL+IFIX(FLOAT(IH-IL)*(TT-X(IL))/(X(IH)-X(IL))), * IH-1) IF (TT .LT. X(I)) GO TO 2 IF (TT .LT. X(I+1)) GO TO 3 C C Too high C IL = I+1 GO TO 1 C C Too low C 2 IH = I GO TO 1 3 INTRVL = I RETURN C C Left end C 4 INTRVL = 1 RETURN C C Right end C 5 INTRVL = N-1 RETURN END C C======================================================================= Cfmod.pl 0100666 0000765 0000765 00000000710 07041770544 011721 0 ustar bulant bulant #!perl #
# # Perl script to compile package MODEL by means of perl script f.pl. # require 'f.pl'; # &COMPILE('modchk'); &COMPILE('modsrf'); &COMPILE('bndlin'); &COMPILE('grid'); &COMPILE('sec'); &COMPILE('intf'); &COMPILE('invsoft'); &COMPILE('invpts'); &COMPILE('modmod'); &COMPILE('modle2d'); # 1; #grid.for 0100666 0000765 0000765 00000073654 07226001610 012077 0 ustar bulant bulant C
C Program GRID to discretize functions, specifying velocities and other C material parameters or describing structural interfaces, at gridpoints C of a regular rectangular grid. C C Useful for the full wave finite differences, the shortest path C calculation of seismic rays, eikonal equation 'finite differences', C raster imaging of the model, or generating test data for inversion. C Note that also an oblique vertical 2-D section across the 3-D model C may be gridded. C C Version: 5.50 C Date: 2001, January 7 C C Coded by: Ludek Klimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C The rectangular grid is specified in Cartesian coordinates, and then C transformed to the model coordinates. For the Cartesian coordinates C connected with a particular kind of curvilinear model coordinates see C subroutine CARTES of the file 'metric.for'. C Subroutine CARTES C The rectangular grid could also be specified in respect to the model C coordinates, and limited by coordinate planes specified in the model C coordinates. This option may be enabled by changing the value of the C input parameter KOORGRD=0 (default) to KOORGRD=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 Input file specifying the model: C MODEL='string'... Input data file describing the model, it is C described in the subroutine file 'model.for'. C Description of file MODEL C Default: 'MODEL'='model.dat' C KOORGRD=integer... Coordinates for discretization: C KOORGRD=0: Cartesian coordinates. C KOORGRD=1: Model coordinates. C Default: KOORGRD=0 C Data specifying the function to be gridded: C ISRF=integer... C ISRF=0: Material parameters in complex blocks will be C gridded (default). C ISRF=positive integer: Function describing surface ISRF C will be gridded. C Default: ISRF=0 C ICBEXT=integer... Used if ISRF=0: C ICBEXT=0: Indices of complex blocks will be determined at C the gridpoints and the material parameters will C correspond to the complex blocks (default). C ICBEXT=positive integer: Material parameters of complex C block ICBEXT will be calculated at all gridpoints C (complex block ICBEXT is extended to the whole grid). C Default: ICBEXT=0 C MPAR=integer... Material parameter to be gridded. C Used if ISRF=0: C MPAR=0: The material parameter for each block is listed in C input file LPAR (default). C MPAR=positive integer: Parameter number MPAR will be C gridded in each complex block: C MPAR=1: P wave velocity, C MPAR=2: S wave velocity, C MPAR=3: density, C MPAR=4: P wave loss factor, C MPAR=5: S wave loss factor, C MPAR=6 to 26: Reduced (i.e., divided by the density) C anisotropic elastic parameters A11, A12, A22, A13, C A23, A33, A14, A24, A34, A44, A15, A25, A35, A45, A55, C A16, A26, A36, A46, A56 or A66. C MPAR=27-47: Reduced (i.e., divided by the density) C imaginary parts of anisotropic elastic parameters Q11, C Q12, Q22, Q13, Q23, Q33, Q14, Q24, Q34, Q44, Q15, Q25, C Q35, Q45, Q55, Q16, Q26, Q36, Q46, Q56 or Q66. C Default: MPAR=0 C LPAR='string'... Name of the input formatted file containing the C list of material parameters to be gridded. C The file should contain one integer MPAR(k) per each C complex block k. The meaning of integers MPAR(k) is C analogous to input parameter MPAR. In addition, MPAR(k)=0 C means zeros in the corresponding complex block. C The default values of all integers MPAR(k) are 1 (P-wave C velocity). LPAR=' ' (default) has the same meaning as C MPAR=1. C Used if ISRF=0 and MPAR=0. C Default: LPAR=' ' C Data specifying filenames with gridded values: C IND='string'... If not blank, the name of the index file. C This option enables to specify other than rectangular C region covered by a rectangular grid: C The rectangular volume bounded by coordinate limits C X1MIN,X1MAX, X2MIN,X2MAX, AND X3MIN,X3MAX is divided into C N1*N2*N3 big bricks. Each element (index) of the index C file corresponds to one big brick. If it equals zero, C the big brick does not belong to the region in which the C velocity is discretized. C Description of file IND C Default: IND=' ' C ICB='string'... Name of the output formatted file containing the C indices of complex geological blocks at the gridpoints if C ICBEXT=0. Otherwise, the file would be filled by the value C of ICBEXT. C If ICB is blank (default), the file is not created. C Description of the output files C Default: ICB=' ' C VEL='string'... Name of the output formatted file, C containing the velocities, other material parameters or C the values of the function describing the given surface C at the gridpoints. C Velocity=0 is inserted in a free space. C If blank, the file is not created. C Description of the output files C Default: VEL='vel.out' C VEL1='string', VEL2='string', VEL3='string', VEL11='string', C VEL12='string', VEL22='string', VEL13='string', VEL23='string', C VEL33='string'... Names of the output formatted files containing C individual first or second partial velocity derivatives C at the given gridpoints. C If the filename is blank, the corresponding file is not C created. C Description of the output files C Defaults: VEL1=' ', VEL2=' ', VEL3=' ', VEL11=' ', C VEL12=' ', VEL22=' ', VEL13=' ', VEL23=' ', VEL33=' ' C Data specifying grid dimensions: C N1=positive integer... Number of gridpoints along the X1 axis. C Default: N1=1 C Special option of N1=0: C 2-D oblique vertical section in 3-D: C The rectangular vertical section bounded by the vertical C lines (X1,X2)=(X1MIN,X2MIN) and (X1,X2)=(X1MAX,X2MAX), C from X3=X3MIN to X3=X3MAX is divided into N2*N3 cells. C Here C X1MIN=O1-0.5*D1, X1MAX=X1MIN+FLOAT(N2)*D1, C X2MIN=O2-0.5*D2, X2MAX=X2MIN+FLOAT(N2)*D2, C X3MIN=O3-0.5*D3, X3MAX=X3MIN+FLOAT(N3)*D3. 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 Additional parameters for a special option: C The rectangular volume bounded by coordinate limits C X1MIN,X1MAX, X2MIN,X2MAX, and X3MIN,X3MAX is divided into C N1*N2*N3 big bricks. Here C X1MIN=O1-0.5*D1, X1MAX=X1MIN+FLOAT(N1)*D1, C X2MIN=O2-0.5*D2, X2MAX=X2MIN+FLOAT(N2)*D2, C X3MIN=O3-0.5*D3, X3MAX=X3MIN+FLOAT(N3)*D3. C Then (if the numbers L1,L2,L3 are specified in addition to C N1,N2,N3) each big brick is subdivided into L1*L2*L3 small C bricks. C The output velocities are computed in the centres of small C bricks. C Outer loop is over big bricks, the discrete velocities C within each big brick being output consecutively. C A special option of N1=0: C 2-D oblique vertical section in 3-D: C The rectangular vertical section bounded by the vertical C lines (X1,X2)=(X1MIN,X2MIN) and (X1,X2)=(X1MAX,X2MAX), C from X3=X3MIN to X3=X3MAX is divided into N2*N3 big C cells, each big cell being divided into L2*L3 small C cells. C L1=positive integer... Number of small bricks in one big brick in C the direction of axis X1. If specified, must be positive. C Default: L1=1 C L2=positive integer... Number of small bricks in one big brick in C the direction of axis X2. If specified, must be positive. C Default: L2=1 C L3=positive integer... Number of small bricks in one big brick in C the direction of axis X3. If specified, must be positive. C Default: L3=1 C (If the numbers L1,L2,L3 are not specified, each big brick C contains just one small brick, as large as big one.) C Example of data set SEP C C C Input file 'IND': C This option enables to specify other than rectangular C region covered by a rectangular grid: C The rectangular volume bounded by coordinate limits C X1MIN,X1MAX, X2MIN,X2MAX, and X3MIN,X3MAX is divided into C N1*N2*N3 big bricks. Each element (index) of the index C file corresponds to one big brick. If it equals zero, C the big brick does not belong to the region in which the C velocity is discretized. C Attention: The nonzero indices must be formed by the sequence C 1,2,3,... of positive integers. C (1) (IND(I),I=1,N1*N2*N3) C IND(I)..Zero if the I-th big brick does not belong to the region C in which the velocity is discretized. C Otherwise the index the big brick. The gridpoints within C the big brick are indexed by integers from C L1*L2*L3*(IND(I)-1)+1 to L1*L2*L3*IND(I). C Default: IND(I)=I. C C C Output files 'VEL','VEL1','VEL2','VEL3','VEL11','VEL12','VEL22', C 'VEL13','VEL23': C (1) (V(I),I=1,L1234), where L1234 is the number of gridpoints. C L1234=L1*L2*L3*L4. If the file 'IND' is not specified, C L4=N1*N2*N3 by the default. C V(I)... Velocity or its partial derivative at the I-th gridpoint. C Free space is indicated by a zero velocity or derivative C V(I)=0. C C Output file 'ICB': C (1) (ICB(I),I=1,L1234), where L1234 is the number of gridpoints. C ICB(I)..Index of (geological) block in which the I-th gridpoint C is situated. C For general description of the files with gridded data refer to file C forms.htm. C C....................................................................... C C Subroutines referenced: EXTERNAL KOOR,MODEL1,BLOCK,VELOC,PARM2,WARRAY INTEGER KOOR C KOOR... File 'metric.for'. C MODEL1,BLOCK,VELOC... File 'model.for'. C PARM2...File 'parm.for'. C WARRAY..File 'forms.for'. C Note that the above subroutines reference many other external C procedures from various source code files of the 'MODEL' subroutine C package. These indirectly referenced procedures are not named here, C but are listed in the particular subroutine source code files. C C----------------------------------------------------------------------- C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C....................................................................... C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of arrays: INTEGER MVEL,MIND PARAMETER (MVEL=10000,MIND=MRAM-11*MVEL) INTEGER ICB(MVEL),IND(MIND) REAL VOUT(MVEL),VOUD(MVEL,9) EQUIVALENCE (VOUT,RAM) EQUIVALENCE (ICB,RAM(MVEL+1)) EQUIVALENCE (VOUD,RAM(2*MVEL+1)) EQUIVALENCE (IND,RAM(11*MVEL+1)) C C....................................................................... C C Storage locations: C C Input data: CHARACTER*80 FGRID,FMODEL,FSEP,FIND,FVEL,FICB,FVELD(9) INTEGER LU1,LU2,LUD(9),MPS PARAMETER (LU1=1,LU2=2,MPS=100) INTEGER ISRF,ICBEXT,MPAR INTEGER N1,N2,N3,L1,L2,L3,IPS(MPS) REAL D1,D2,D3,O1,O2,O3 REAL X1MIN,X2MIN,X3MIN,X1MAX,X2MAX,X3MAX C C LU1,LU2,LUD... Logical unit numbers. C C Others: LOGICAL LIND,LVEL0,LICB,LVELD,LVEL(9),LOBLIQ INTEGER KOORG INTEGER N123,L1234,I1234,IN1,IN2,IN3,IL1,IL2,IL3,IBRICK,INDOLD INTEGER NVEL,ISRF2,ISB2,ICB2,I,II REAL DX1,DX2,DX3 REAL COOR(3),UP(10),US(10),VD(10),AUX0,AUX1,AUX2,AUX3,AUX4 REAL G(12),GAMMA(18),PDER(9),AUX11,AUX12,AUX22,AUX13,AUX23,AUX33 REAL A(10,21),Q(21) C C KOORG...0 if the model specified in curvilinear coordinates is C gridded in Cartesian coordinates. C LIND... Indication of indexed grid to specify irregular subvolume C of the rectangular volume covered by the grid. C LVEL0,LICB,LVELD,LVEL... Indication of opening and generating C output files. C LOBLIQ..Indication of a special option enabling to grid an oblique C vertical profile. C ICB... Indices of complex blocks. C ISRF2...Index of a surface, see subroutine block. C ISB2... Index of the simple block, see subroutine block. C ICB2... Index of the complex block, see subroutine block. C I... Index of a gridpoint, or loop variable. C DX1,DX2,DX3... Grid intervals. C VEL... Velocity. C COOR... Coordinates of a gridpoint. C UP,US,VD,AUX0,AUX1,AUX2,AUX3,AUX4... Auxiliary storage locations C for local model parameters or temporary variables. C G,GAMMA,PDER,AUX11,AUX12,AUX22,AUX13,AUX23,AUX33... Auxiliary C storage locations used in coordinate transformations. C DATA LUD/3,4,5,6,7,8,9,10,11/ C C....................................................................... C C Opening files and reading input data: C C Name of main input data: FSEP=' ' WRITE(*,'(A)') '+GRID: Enter input filename: ' READ(*,*) FSEP C C Reading all data from the SEP file into the memory: IF (FSEP.NE.' ') THEN CALL RSEP1(LU1,FSEP) ELSE C GRID-07 CALL ERROR('GRID-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 WRITE(*,'(A)') '+GRID: Reading data... ' C C Reading filenames: CALL RSEP3T('IND' ,FIND ,' ') CALL RSEP3T('ICB' ,FICB ,' ') CALL RSEP3T('VEL' ,FVEL ,'vel.out') CALL RSEP3T('VEL1' ,FVELD(1),' ') CALL RSEP3T('VEL2' ,FVELD(2),' ') CALL RSEP3T('VEL3' ,FVELD(3),' ') CALL RSEP3T('VEL11',FVELD(4),' ') CALL RSEP3T('VEL12',FVELD(5),' ') CALL RSEP3T('VEL22',FVELD(6),' ') CALL RSEP3T('VEL13',FVELD(7),' ') CALL RSEP3T('VEL23',FVELD(8),' ') CALL RSEP3T('VEL33',FVELD(9),' ') C C Data for model: CALL RSEP3T('MODEL',FMODEL,'model.dat') OPEN(LU1,FILE=FMODEL,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) CALL RSEP3I('KOORGRD',KOORG,0) IF(KOOR().EQ.0) THEN C No transformation between Cartesian and model coordinates KOORG=1 END IF C C Reading indices of material parameters: CALL RSEP3I('ISRF',ISRF,0) CALL RSEP3I('ICBEXT',ICBEXT,0) CALL RSEP3I('MPAR',MPAR,0) IF(MPS.LT.NCB) THEN C GRID-01 CALL ERROR('GRID-01: Too small array IPS(MPS)') END IF DO 11 I=1,NCB IPS(I)=MAX0(1,MPAR) 11 CONTINUE IF(MPAR.EQ.0) THEN CALL RSEP3T('LPAR',FGRID,' ') IF(FGRID.NE.' ') THEN OPEN(LU1,FILE=FGRID,STATUS='OLD') READ(LU1,*) (IPS(I),I=1,NCB) CLOSE(LU1) END IF END IF C C Data for grid: CALL RSEP3I('N1',N1,1) CALL RSEP3I('N2',N2,1) CALL RSEP3I('N3',N3,1) CALL RSEP3I('L1',L1,1) CALL RSEP3I('L2',L2,1) CALL RSEP3I('L3',L3,1) IF(N1.EQ.0) THEN C Vertical oblique profile IF(L1.NE.0.AND.L1.NE.1) THEN C GRID-02 CALL ERROR('GRID-02: Incorrect L1 for an oblique profile') END IF LOBLIQ=.TRUE. N1=1 L1=1 ELSE LOBLIQ=.FALSE. END IF IF(N1.LT.1.OR.N2.LT.1.OR.N3.LT.1.OR.L1.LT.1.OR.L2.LT.1.OR.L3.LT.1) * THEN C GRID-03 CALL ERROR('GRID-03: Non-positive number of gridpoints') END IF CALL RSEP3R('D1',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) X1MIN=O1-0.5*D1 X2MIN=O2-0.5*D2 X3MIN=O3-0.5*D3 IF(LOBLIQ) THEN X1MAX=X1MIN+FLOAT(N2)*D1 ELSE X1MAX=X1MIN+FLOAT(N1)*D1 END IF X2MAX=X2MIN+FLOAT(N2)*D2 X3MAX=X3MIN+FLOAT(N3)*D3 C C Reading the index array: IF(FIND.EQ.' ') THEN LIND=.FALSE. IND(1)=1 L1234=L1*L2*L3*N1*N2*N3 ELSE LIND=.TRUE. N123=N1*N2*N3 IF(N123.GT.MIND) THEN C GRID-04 CALL ERROR('GRID-04: Too many big bricks') END IF DO 31 IBRICK=1,N123 IND(IBRICK)=IBRICK 31 CONTINUE OPEN(LU1,FILE=FIND,STATUS='OLD') READ(LU1,*) (IND(IBRICK),IBRICK=1,N123) CLOSE(LU1) L1234=0 DO 32 IBRICK=1,N123 IF(IND(IBRICK).GT.0) THEN L1234=L1234+1 END IF 32 CONTINUE L1234=L1*L2*L3*L1234 END IF C C Output file with velocities at gridpoints: IF(FVEL.EQ.' ') THEN LVEL0=.FALSE. ELSE LVEL0=.TRUE. OPEN(LU1,FILE=FVEL) END IF C C Output file with indices of complex blocks: IF(FICB.EQ.' ') THEN LICB=.FALSE. ELSE LICB=.TRUE. OPEN(LU2,FILE=FICB) END IF C C Output file with velocity derivatives at gridpoints: LVELD=.FALSE. DO 33 I=1,9 IF(FVELD(I).EQ.' ') THEN LVEL(I)=.FALSE. ELSE LVELD =.TRUE. LVEL(I)=.TRUE. OPEN(LUD(I),FILE=FVELD(I)) END IF 33 CONTINUE C C....................................................................... C C Loops over gridpoints: C IF(LOBLIQ) THEN DX1=(X1MAX-X1MIN)/FLOAT(N2*L2) ELSE DX1=(X1MAX-X1MIN)/FLOAT(N1*L1) END IF DX2=(X2MAX-X2MIN)/FLOAT(N2*L2) DX3=(X3MAX-X3MIN)/FLOAT(N3*L3) NVEL=0 IBRICK=0 INDOLD=0 I1234=0 WRITE(*,'(''+GRID: '',I16,'' gridpoints of'',I9)') I1234,L1234 C C Loop over big bricks: DO 83 IN3=0,N3-1 DO 82 IN2=0,N2-1 DO 81 IN1=0,N1-1 C C Check for the computational volume: IF(LIND) THEN IBRICK=IBRICK+1 IF(IND(IBRICK).EQ.0) THEN GO TO 80 END IF IF(IND(IBRICK).NE.INDOLD+1) THEN C GRID-05 CALL ERROR('GRID-05: Indices not consecutive') END IF INDOLD=IND(IBRICK) END IF C C Loop over small bricks: DO 73 IL3=1,L3 COOR(3)=X3MIN+DX3*(FLOAT(IN3*L3+IL3)-0.5) DO 72 IL2=1,L2 COOR(2)=X2MIN+DX2*(FLOAT(IN2*L2+IL2)-0.5) DO 71 IL1=1,L1 IF(LOBLIQ) THEN COOR(1)=X1MIN+DX1*(FLOAT(IN2*L2+IL2)-0.5) ELSE COOR(1)=X1MIN+DX1*(FLOAT(IN1*L1+IL1)-0.5) END IF C C Transformation from Cartesian to model coordinates: IF(KOORG.EQ.0) THEN G(1)=COOR(1) G(2)=COOR(2) G(3)=COOR(3) CALL CARTES(COOR,.FALSE.,G,PDER) END IF C C Velocity evaluation: IF(ISRF.EQ.0) THEN IF(ICBEXT.EQ.0) THEN CALL BLOCK(COOR,0,0,ISRF2,ISB2,ICB2) ELSE ICB2=ICBEXT END IF IF(ICB2.EQ.0) THEN C Free space: DO 41 I=1,10 VD(I)=0. 41 CONTINUE ELSE IF(IPS(ICB2).EQ.0) THEN C Deemed free space: ICB2=0 DO 42 I=1,10 VD(I)=0. 42 CONTINUE ELSE IF(IPS(ICB2).LE.5) THEN C Isotropic elastic parameters: CALL PARM2(IABS(ICB2),COOR,UP,US,AUX0,AUX1,AUX2) IF(IPS(ICB2).EQ.1.OR.IPS(ICB2).EQ.4) THEN CALL VELOC( 1,UP,US,AUX1,AUX2,AUX3,AUX4,VD,AUX0) ELSE IF(IPS(ICB2).EQ.2.OR.IPS(ICB2).EQ.5) THEN CALL VELOC(-1,UP,US,AUX1,AUX2,AUX3,AUX4,VD,AUX0) END IF IF(IPS(ICB2).GT.2) THEN VD(1)=AUX0 DO 43 I=2,10 VD(I)=0. 43 CONTINUE END IF ELSE IF(IPS(ICB2).LE.47) THEN C Anisotropic elastic parameters: CALL PARM3(IABS(ICB2),COOR,A,AUX0,Q) IF(IPS(ICB2).LE.26) THEN DO 46 I=1,10 VD(I)=A(I,IPS(ICB2)-5) 46 CONTINUE ELSE VD(1)=Q(IPS(ICB2)-26) DO 47 I=2,10 VD(I)=0. 47 CONTINUE END IF ELSE C C GRID-06 CALL ERROR('GRID-06: Wrong material parameter') C Material parameters are indexed by integers C from 1 to 47, but index greater than 47 has been C encountered. Check the input data. END IF ELSE CALL SRFC2(ISRF,COOR,VD) END IF C C Writing output files: IF(NVEL.EQ.MVEL) THEN WRITE(*,'(''+GRID: Writing'',I9)') I1234 IF(LVEL0) THEN CALL WARRAY(LU1,' ','FORMATTED', * .FALSE.,0.,.FALSE.,0.,MVEL,VOUT) C For velocities up to 9.99999, the above statement C might be replaced, for instance, by: C WRITE(LU1,'(10F8.5)') VOUT END IF IF(LICB) THEN WRITE(LU2,'(20(1X,I2))') ICB END IF DO 51 I=1,9 IF(LVEL(I)) THEN CALL WARRAY(LUD(I),' ','FORMATTED', * .FALSE.,0.,.FALSE.,0.,MVEL,VOUD(1,I)) END IF 51 CONTINUE NVEL=0 WRITE(*,'(''+GRID: '')') END IF NVEL=NVEL+1 VOUT(NVEL)=VD(1) ICB (NVEL)=ICB2 IF(LVELD) THEN IF(KOORG.EQ.0) THEN C Transformation from model to Cartesian coordinates C covariant derivatives CALL METRIC(COOR,AUX1,G,GAMMA) AUX1=VD(2) AUX2=VD(3) AUX3=VD(4) AUX11=VD( 5)-GAMMA(1)*AUX1-GAMMA( 7)*AUX2 * -GAMMA(13)*AUX3 AUX12=VD( 6)-GAMMA(2)*AUX1-GAMMA( 8)*AUX2 * -GAMMA(14)*AUX3 AUX22=VD( 7)-GAMMA(3)*AUX1-GAMMA( 9)*AUX2 * -GAMMA(15)*AUX3 AUX13=VD( 8)-GAMMA(4)*AUX1-GAMMA(10)*AUX2 * -GAMMA(16)*AUX3 AUX23=VD( 9)-GAMMA(5)*AUX1-GAMMA(11)*AUX2 * -GAMMA(17)*AUX3 AUX33=VD(10)-GAMMA(6)*AUX1-GAMMA(12)*AUX2 * -GAMMA(18)*AUX3 C Transformation of derivatives VD(2)= AUX1*PDER(1)+ AUX2*PDER(2)+ AUX3*PDER(3) VD(3)= AUX1*PDER(4)+ AUX2*PDER(5)+ AUX3*PDER(6) VD(4)= AUX1*PDER(7)+ AUX2*PDER(8)+ AUX3*PDER(9) AUX1 =AUX11*PDER(1)+AUX12*PDER(2)+AUX13*PDER(3) AUX2 =AUX12*PDER(1)+AUX22*PDER(2)+AUX23*PDER(3) AUX3 =AUX13*PDER(1)+AUX23*PDER(2)+AUX33*PDER(3) VD(5)= AUX1*PDER(1)+ AUX2*PDER(2)+ AUX3*PDER(3) AUX1 =AUX11*PDER(4)+AUX12*PDER(5)+AUX13*PDER(6) AUX2 =AUX12*PDER(4)+AUX22*PDER(5)+AUX23*PDER(6) AUX3 =AUX13*PDER(4)+AUX23*PDER(5)+AUX33*PDER(6) VD(6)= AUX1*PDER(1)+ AUX2*PDER(2)+ AUX3*PDER(3) VD(7)= AUX1*PDER(4)+ AUX2*PDER(5)+ AUX3*PDER(6) AUX1 =AUX11*PDER(7)+AUX12*PDER(8)+AUX13*PDER(9) AUX2 =AUX12*PDER(7)+AUX22*PDER(8)+AUX23*PDER(9) AUX3 =AUX13*PDER(7)+AUX23*PDER(8)+AUX33*PDER(9) VD(8)= AUX1*PDER(1)+ AUX2*PDER(2)+ AUX3*PDER(3) VD(9)= AUX1*PDER(4)+ AUX2*PDER(5)+ AUX3*PDER(6) VD(10)=AUX1*PDER(7)+ AUX2*PDER(8)+ AUX3*PDER(9) END IF DO 61 I=1,9 IF(LVEL(I)) THEN VOUD(NVEL,I)=VD(I+1) END IF 61 CONTINUE END IF C C Screen output: I1234=I1234+1 IF(MOD(I1234,1000).EQ.0) THEN WRITE(*,'(''+GRID: '',I16)') I1234 END IF C 71 CONTINUE 72 CONTINUE 73 CONTINUE C 80 CONTINUE 81 CONTINUE 82 CONTINUE 83 CONTINUE C C Rest of output files: IF(NVEL.GT.0) THEN WRITE(*,'(''+GRID: Writing'',I9)') I1234 IF(LVEL0) THEN CALL WARRAY(LU1,' ','FORMATTED', * .FALSE.,0.,.FALSE.,0.,NVEL,VOUT) C For velocities up to 9.99999, the above statement C might be replaced, for instance, by: C WRITE(LU1,'(10F8.5)') (VOUT(I),I=1,NVEL) END IF IF(LICB) THEN WRITE(LU2,'(20(1X,I2))') (ICB(I),I=1,NVEL) END IF DO 91 I=1,9 IF(LVEL(I)) THEN CALL WARRAY(LUD(I),' ','FORMATTED', * .FALSE.,0.,.FALSE.,0.,NVEL,VOUD(1,I)) END IF 91 CONTINUE NVEL=0 END IF C C Screen output: WRITE(*,'(''+GRID: Done'',I12)') I1234 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for C C======================================================================= Chpcg.for 0100666 0000765 0000765 00000027716 05306040122 012067 0 ustar bulant bulant C SUBROUTINE 'HPCG' 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 HPCG C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY GENERAL C DIFFERENTIAL EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL HPCG (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER C OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF C THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR C COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED C BY THE USER) AND SUBROUTINE HPCG. EXCEPT PRMT(5) C THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE C HPCG AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE HPCG INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE HPCG AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE HPCG DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING HPCG) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - INPUT VECTOR OF INITIAL VALUES. (DESTROYED) C LATERON Y IS THE RESULTING VECTOR OF DEPENDENT C VARIABLES COMPUTED AT INTERMEDIATE POINTS X. C DERY - INPUT VECTOR OF ERROR WEIGHTS. (DESTROYED) C THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1. C LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH C BELONG TO FUNCTION VALUES Y AT A POINT X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE HPCG RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C ERROR MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. IT C COMPUTES THE RIGHT HAND SIDES DERY OF THE SYSTEM C TO GIVEN VALUES OF X AND Y. ITS PARAMETER LIST C MUST BE X,Y,DERY. THE SUBROUTINE SHOULD NOT C DESTROY X AND Y. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE HPCG IS TERMINATED. C AUX - AN AUXILIARY STORAGE ARRAY WITH 16 ROWS AND NDIM C COLUMNS. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF HAMMINGS MODIFIED PREDICTOR- C CORRECTOR METHOD. IT IS A FOURTH ORDER METHOD, USING 4 C PRECEEDING POINTS FOR COMPUTATION OF A NEW VECTOR Y OF THE C DEPENDENT VARIABLES. C FOURTH ORDER RUNGE-KUTTA METHOD SUGGESTED BY RALSTON IS C USED FOR ADJUSTMENT OF THE INITIAL INCREMENT AND FOR C COMPUTATION OF STARTING VALUES. C SUBROUTINE HPCG AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE CODED BY THE USER. C FOR REFERENCE, SEE C (1) RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL C COMPUTERS, WILEY, NEW YORK/LONDON, 1960, PP.95-109. C (2) RALSTON, RUNGE-KUTTA METHODS WITH MINIMUM ERROR BOUNDS, C MTAC, VOL.16, ISS.80 (1962), PP.431-437. C C .................................................................. C SUBROUTINE HPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C DIMENSION PRMT(*),Y(*),DERY(*),AUX(16,*) N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0. DO 1 I=1,NDIM AUX(16,I)=0. AUX(15,I)=DERY(I) 1 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))3,2,4 C C ERROR RETURNS 2 IHLF=12 GOTO 4 3 IHLF=13 C C COMPUTATION OF DERY FOR STARTING VALUES 4 CALL FCT(X,Y,DERY) C C RECORDING OF STARTING VALUES CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,5,6 5 IF(IHLF)7,7,6 6 RETURN 7 DO 8 I=1,NDIM 8 AUX(8,I)=DERY(I) C C COMPUTATION OF AUX(2,I) ISW=1 GOTO 100 C 9 X=X+H DO 10 I=1,NDIM 10 AUX(2,I)=Y(I) C C INCREMENT H IS TESTED BY MEANS OF BISECTION 11 IHLF=IHLF+1 X=X-H DO 12 I=1,NDIM 12 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW=2 GOTO 100 C 13 X=X+H CALL FCT(X,Y,DERY) N=2 DO 14 I=1,NDIM AUX(2,I)=Y(I) 14 AUX(9,I)=DERY(I) ISW=3 GOTO 100 C C COMPUTATION OF TEST VALUE DELT 15 DELT=0. DO 16 I=1,NDIM 16 DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I)) DELT=.06666667*DELT IF(DELT-PRMT(4))19,19,17 17 IF(IHLF-10)11,18,18 C C NO SATISFACTORY ACCURACY AFTER 10 BISECTIONS. ERROR MESSAGE. 18 IHLF=11 X=X+H GOTO 4 C C THERE IS SATISFACTORY ACCURACY AFTER LESS THAN 11 BISECTIONS. 19 X=X+H CALL FCT(X,Y,DERY) DO 20 I=1,NDIM AUX(3,I)=Y(I) 20 AUX(10,I)=DERY(I) N=3 ISW=4 GOTO 100 C 21 N=1 X=X+H CALL FCT(X,Y,DERY) X=PRMT(1) DO 22 I=1,NDIM AUX(11,I)=DERY(I) 220Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 23 X=X+H N=N+1 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,24,6 24 IF(N-4)25,200,200 25 DO 26 I=1,NDIM AUX(N,I)=Y(I) 26 AUX(N+7,I)=DERY(I) IF(N-3)27,29,200 C 27 DO 28 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 28 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 23 C 29 DO 30 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 30 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 23 C C THE FOLLOWING PART OF SUBROUTINE HPCG COMPUTES BY MEANS OF C RUNGE-KUTTA METHOD STARTING VALUES FOR THE NOT SELF-STARTING C PREDICTOR-CORRECTOR METHOD. 100 DO 101 I=1,NDIM Z=H*AUX(N+7,I) AUX(5,I)=Z 101 Y(I)=AUX(N,I)+.4*Z C Z IS AN AUXILIARY STORAGE LOCATION C Z=X+.4*H CALL FCT(Z,Y,DERY) DO 102 I=1,NDIM Z=H*DERY(I) AUX(6,I)=Z 102 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*Z C Z=X+.4557372*H CALL FCT(Z,Y,DERY) DO 103 I=1,NDIM Z=H*DERY(I) AUX(7,I)=Z 103 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*Z C Z=X+H CALL FCT(Z,Y,DERY) DO 104 I=1,NDIM 1040Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) GOTO(9,13,15,21),ISW C C POSSIBLE BREAK-POINT FOR LINKAGE C C STARTING VALUES ARE COMPUTED. C NOW START HAMMINGS MODIFIED PREDICTOR-CORRECTOR METHOD. 200 ISTEP=3 201 IF(N-8)204,202,204 C C N=8 CAUSES THE ROWS OF AUX TO CHANGE THEIR STORAGE LOCATIONS 202 DO 203 N=2,7 DO 203 I=1,NDIM AUX(N-1,I)=AUX(N,I) 203 AUX(N+6,I)=AUX(N+7,I) N=7 C C N LESS THAN 8 CAUSES N+1 TO GET N 204 N=N+1 C C COMPUTATION OF NEXT VECTOR Y DO 205 I=1,NDIM AUX(N-1,I)=Y(I) 205 AUX(N+6,I)=DERY(I) X=X+H 206 ISTEP=ISTEP+1 DO 207 I=1,NDIM 0DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 207 AUX(16,I)=DELT C PREDICTOR IS NOW GENERATED IN ROW 16 OF AUX, MODIFIED PREDICTOR C IS GENERATED IN Y. DELT MEANS AN AUXILIARY STORAGE. C CALL FCT(X,Y,DERY) C DERIVATIVE OF MODIFIED PREDICTOR IS GENERATED IN DERY C DO 208 I=1,NDIM 0DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 208 Y(I)=DELT+.07438017*AUX(16,I) C C TEST WHETHER H MUST BE HALVED OR DOUBLED DELT=0. DO 209 I=1,NDIM 209 DELT=DELT+AUX(15,I)*ABS(AUX(16,I)) IF(DELT-PRMT(4))210,222,222 C C H MUST NOT BE HALVED. THAT MEANS Y(I) ARE GOOD. 210 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))212,211,212 211 IF(IHLF-11)213,212,212 212 RETURN 213 IF(H*(X-PRMT(2)))214,212,212 214 IF(ABS(X-PRMT(2))-.1*ABS(H))212,215,215 215 IF(DELT-.02*PRMT(4))216,216,201 C C C H COULD BE DOUBLED IF ALL NECESSARY PRECEEDING VALUES ARE C AVAILABLE 216 IF(IHLF)201,201,217 217 IF(N-7)201,218,218 218 IF(ISTEP-4)201,219,219 219 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)201,220,201 220 H=H+H IHLF=IHLF-1 ISTEP=0 DO 221 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 2210AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 201 C C C H MUST BE HALVED 222 IHLF=IHLF+1 IF(IHLF-10)223,223,210 223 H=.5*H ISTEP=0 DO 224 I=1,NDIM 0Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 224 AUX(N+4,I)=AUX(N+5,I) X=X-H DELT=X-(H+H) CALL FCT(DELT,Y,DERY) DO 225 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 225 Y(I)=AUX(N-4,I) DELT=DELT-(H+H) CALL FCT(DELT,Y,DERY) DO 226 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 226 AUX(N+3,I)=DERY(I) GOTO 206 END C C======================================================================= C intf.for 0100666 0000765 0000765 00000034302 07262011410 012074 0 ustar bulant bulant C
C Program INTF to check the positions of given points with respect to C interfaces in the model. C C Version: 5.50 C Date: 2001, April 2 C C Coded by: Ludek Klimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Names of the input and output files: C MODEL='string'... Name of the input file with the data specifying C the model. Only the points within the model volume are C processed and written in this version. C Description of MODEL C Example of MODEL C Default: MODEL='model.dat' C INTF='string'... Name of the input data file containing the C points situated at (or close to) interface(s). C Description of file INTF C Default: INTF='intf.dat' C INTFOUT='string'... Name of the output data file containing the C value F(X1,X2,X3) of the function describing the C corresponding surface, evaluated at the given points. C Description of file INTFOUT C Default: INTFOUT='intf.out' C Data specific to this program: C KSRFC=integer ... Parameter describing the form of file INTF: C KSRFC=0: Points submitted in file INTF correspond to C various surfaces in the model. Each point thus must be C supplemented with the index of the surface. C KSRFC.NE.0: Points submitted in file INTF correspond to C surface number IABS(KSRFC). C KSRFC.GT.0: Input file INTF has format C POINTS. C KSRFC.LT.0: Input file INTF has format C LINES. C Default: KSRFC=0 C KOLUMN=integer ... Specifies the position in output file INTFOUT C where to write value F(X1,X2,X3) of the function C describing the corresponding surface, evaluated at the C given points. At most 98 columns are considered. C If the input file INTF has format LINES, the columns C are indexed from 1, in the other two cases the columns C are indexed from 0, the column 0 then contains either C the name of a point or the index of the surface and cannot C be modified. C If KOLUMN=0, input points are not modified. C For KSRFC=0, KOLUMN is allowed to be KOLUMN=-1, see the C description below. C Default: KOLUMN=4 C C C Input file INTF: C For KSRFC.GT.0: C Input file INTF has format POINTS, see 'formsdat.htm'. C Description of form POINTS C For KSRFC.LT.0: C Input file INTF has format LINES, see 'formsdat.htm'. C Description of form LINES C For KSRFC.EQ.0: C Several lines terminated by a slash or EOF. Each line corresponds C to a given point and contains 4 numbers: C ISRFC,X1,X2,X3 C ISRFC...Index of the surface. C X1,X2,X3... Coordinates of the point. C C C Output file INTFOUT has similar form as input file INTF, depending on C KSRFC and KOLUMN: C For KSRFC=0 and KOLUMN=-1: C Only the index of surface ISRFC and the value F(X1,X2,X3) of the C function describing the corresponding surface are written at C each line of the file. C If the point is situated exactly at the surface, F(X1,X2,X3)=0. C For KOLUMN=0: C Output points situated inside the model volume coincide with the C input ones. Points situated outside the model volume are not C written. C Otherwise: C KOLUMN-th column of the input file is replaced by the value C F(X1,X2,X3) of the function describing the corresponding surface. C If the input file INTF contains less than (KOLUMN-1) values, C the missing values are replaced by the value of parameter ZERO, C see below. C For KOLUMN=1,2,3: C This option may be used to project the points or lines given by 2 C of 3 coordinates on the surfaces described in the simple form of C F(X1,X2,X3)=W(X1,X2)-X3 or F(X1,X2,X3)=W(X1,X3)-X2 or C F(X1,X2,X3)=W(X2,X3)-X1. C Note that only the points within the model volume are written to C output file INTFOUT, which applies also for reference points of the C lines if INTF is of format LINES. C C======================================================================= C C External procedures directly referred: EXTERNAL LENGTH,ERROR,RSEP1,RSEP3T,RSEP3I,MODEL1,SRFC2,FORM1 INTEGER LENGTH C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C----------------------------------------------------------------------- C CHARACTER*80 FILSEP INTEGER LU0 PARAMETER (LU0=1) C C Filenames: CHARACTER*80 FILE0,FILE1,FILE2 C C Logical unit numbers: INTEGER LU1,LU2 PARAMETER (LU1=11) PARAMETER (LU2=12) C C Data: CHARACTER*80 TEXT CHARACTER*20 FORMAT,FORMAR LOGICAL NEWLIN INTEGER KSRFC,ISRFC,NPTS,I,N,KOLUMN,J1 REAL COOR(98),F(10),FMAX,FRMS,FABS,FAVE,UNDEF,ZERO,OUTMIN,OUTMAX PARAMETER (UNDEF=9.9E9, ZERO=0.) C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+INTF: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP WRITE(*,'(A)') '+INTF: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU0,FILSEP) ELSE C INTF-01 CALL ERROR('INTF-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('MODEL',FILE0,'model.dat') CALL RSEP3T('INTF',FILE1,'intf.dat') CALL RSEP3T('INTFOUT',FILE2,'intf.out') CALL RSEP3I('KSRFC',KSRFC,0) CALL RSEP3I('KOLUMN',KOLUMN,4) C IF ((KOLUMN.LT.-1).OR.(KOLUMN.GT.98).OR. * ((KOLUMN.EQ.-1).AND.(KSRFC.NE.0))) THEN C INTF-02 CALL ERROR('INTF-02: Wrong value of KOLUMN') C Parameter KOLUMN may have values from 0 to 98 in case of C nonzero KSRFC, and from -1 to 98 if KSRFC=0. ENDIF C OPEN(LU1,FILE=FILE0,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) C OPEN(LU1,FILE=FILE1,STATUS='OLD') OPEN(LU2,FILE=FILE2) C IF(KSRFC.NE.0) THEN ISRFC=IABS(KSRFC) READ(LU1,*,END=90) (TEXT,I=1,20) WRITE(LU2,'(A)') '/' END IF C C....................................................................... C C Check of the positions C NEWLIN=.TRUE. NPTS=0 FMAX=0. FRMS=0. FABS=0. FAVE=0. 10 CONTINUE COOR(1)=0. COOR(2)=0. COOR(3)=0. DO 12, I=4,98 COOR(I)=UNDEF 12 CONTINUE TEXT='$' IF(KSRFC.GT.0) THEN C Input format 'Points': READ(LU1,*,END=90) TEXT,(COOR(I),I=1,98) IF(TEXT.EQ.'$') THEN GO TO 90 END IF ELSE IF(KSRFC.LT.0) THEN C Input format 'Lines': COOR(1)=UNDEF IF(NEWLIN) THEN READ(LU1,*,END=90) TEXT,(COOR(I),I=1,98) IF(TEXT.EQ.'$') THEN GO TO 90 END IF NEWLIN=.FALSE. J1=LENGTH(TEXT)+1 TEXT(J1:J1)='''' WRITE(LU2,'(2A)') '''',TEXT(1:J1) IF(COOR(1).EQ.UNDEF) THEN C No reference point: WRITE(LU2,'(A)') '/' GO TO 10 ELSE C Check for the position of the reference point IF(BOUNDM(1).GT.COOR(1).OR.COOR(1).GT.BOUNDM(2).OR. * BOUNDM(3).GT.COOR(2).OR.COOR(2).GT.BOUNDM(4).OR. * BOUNDM(5).GT.COOR(3).OR.COOR(3).GT.BOUNDM(6)) THEN WRITE(LU2,'(A)') '/' END IF END IF ELSE READ(LU1,*,END=90) (COOR(I),I=1,98) IF(COOR(1).EQ.UNDEF) THEN C End of line: NEWLIN=.TRUE. WRITE(LU2,'(A)') '/' GO TO 10 END IF END IF ELSE C (KSRFC=0) Input format for mixed surfaces: ISRFC=0 READ(LU1,*,END=90) ISRFC,(COOR(I),I=1,98) IF(ISRFC.EQ.0) THEN GO TO 90 END IF END IF IF(BOUNDM(1).LE.COOR(1).AND.COOR(1).LE.BOUNDM(2)) THEN IF(BOUNDM(3).LE.COOR(2).AND.COOR(2).LE.BOUNDM(4)) THEN IF(BOUNDM(5).LE.COOR(3).AND.COOR(3).LE.BOUNDM(6)) THEN NPTS=NPTS+1 CALL SRFC2(ISRFC,COOR,F) FMAX=AMAX1(ABS(F(1)),FMAX) FRMS=FRMS+F(1)*F(1) FABS=FABS+ ABS(F(1)) FAVE=FAVE+ F(1) N=MAX0(KOLUMN,0) DO 14, I=KOLUMN+1,98 IF (COOR(I).NE.UNDEF) N=I 14 CONTINUE OUTMIN=F(1) OUTMAX=F(1) DO 16, I=1,N IF (COOR(I).EQ.UNDEF) COOR(I)=ZERO IF((COOR(I).LT.OUTMIN).AND.(I.NE.KOLUMN)) OUTMIN=COOR(I) IF((COOR(I).GT.OUTMAX).AND.(I.NE.KOLUMN)) OUTMAX=COOR(I) 16 CONTINUE FORMAR='F00.0,1X' CALL FORM1(OUTMIN,OUTMAX,FORMAR(1:8)) FORMAR(7:8)='1X' IF(KSRFC.GT.0) THEN C Output format 'Points': J1=LENGTH(TEXT)+1 TEXT(J1:J1)='''' J1=MAX0(J1,9) IF (KOLUMN.NE.0) THEN COOR(KOLUMN)=F(1) ENDIF FORMAT='(2A,00(F00.0,1X),A)' FORMAT(6:6)=CHAR(ICHAR('0')+MOD(N/1,10)) FORMAT(5:5)=CHAR(ICHAR('0')+MOD(N/10,10)) FORMAT(8:15)=FORMAR(1:8) WRITE(LU2,FORMAT) '''',TEXT(1:J1),(COOR(I),I=1,N),' /' ELSE IF(KSRFC.LT.0) THEN C Output format 'lines': IF (KOLUMN.NE.0) THEN COOR(KOLUMN)=F(1) ENDIF FORMAT='(00(F00.0,1X),A)' FORMAT(3:3)=CHAR(ICHAR('0')+MOD(N/1,10)) FORMAT(2:2)=CHAR(ICHAR('0')+MOD(N/10,10)) FORMAT(5:12)=FORMAR(1:8) WRITE(LU2,FORMAT) (COOR(I),I=1,N),' /' ELSE C (KSRFC=0) Output format for mixed surfaces: IF (KOLUMN.EQ.-1) THEN FORMAT='(I3,1F00.0)' FORMAT(6:10)=FORMAR(1:5) WRITE(LU2,FORMAT) ISRFC,F(1) ELSE IF (KOLUMN.NE.0) THEN COOR(KOLUMN)=F(1) ENDIF FORMAT='(I3,00(F00.0,1X))' FORMAT(6:6)=CHAR(ICHAR('0')+MOD(N/1,10)) FORMAT(5:5)=CHAR(ICHAR('0')+MOD(N/10,10)) FORMAT(8:15)=FORMAR(1:8) WRITE(LU2,FORMAT) ISRFC,(COOR(I),I=1,N) END IF END IF END IF END IF END IF GO TO 10 C 90 CONTINUE IF(NPTS.GT.0) THEN FRMS=SQRT(FRMS/FLOAT(NPTS)) FABS= FABS/FLOAT(NPTS) FAVE= FAVE/FLOAT(NPTS) END IF OUTMIN=AMIN1(FMAX,FRMS,FABS,FAVE) OUTMAX=AMAX1(FMAX,FRMS,FABS,FAVE) CALL FORM1(OUTMIN,OUTMAX,FORMAR(1:8)) FORMAT='(A,I0,4(A,F00.0))' I=INT(ALOG10(FLOAT(NPTS)))+1 IF (I.GT.9) THEN C INTF-03 CALL ERROR('INTF-03: Too many points in file INTF') C This format specification allows for maximum of 100 000 000 C of points in file INTF. ENDIF FORMAT(5:5)=CHAR(ICHAR('0')+I) FORMAT(11:15)=FORMAR(1:5) WRITE(LU2,FORMAT) '/',NPTS,' POINTS, MAX=',FMAX, * ', RMS=',FRMS,', ABS=',FABS,', AVERAGE=',FAVE WRITE( * ,FORMAT) '+',NPTS,' POINTS, MAX=',FMAX, * ', RMS=',FRMS,', ABS=',FABS,', AVERAGE=',FAVE WRITE(*,'(A)') ' INTF: 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for C C======================================================================= Cinvpts.for 0100666 0000765 0000765 00000077357 07310334460 012507 0 ustar bulant bulant C
C Program INVPTS to calculate the derivatives of functions, describing C interfaces or material parameters, with respect to the model B-spline C coefficients C C Version: 5.50 C Date: 2001, June 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 Program INVPTS assumes all model parameters (coefficients) stored in C the common block /VALC/ as in the submitted versions of user-defined C model specification FORTRAN77 source code files 'srfc.for', 'parm.for' C and 'val.for'. Thus, unlike the other parts of the complete ray C tracing, the INVTT program cannot work with user's modifications of C subroutines SRFC1, SRFC2, PARM1, and PARM2. C C The material parameters at the given points are converted into such C their powers which are interpolated by B-splines. Then the inversion C of the functions of coordinates is linear and one iteration yields C the exact solution within the rounding errors. On the other hand, C inversion of a material parameter depending on another material C parameters, e.g., RHO=W(VP(X1,X2,X3)), require the second iteration. C More than one iteration may also be required to reduce the rounding C errors. 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 model: C MODEL='string'... Name of the input data file describing the C model. For the description of the data refer to C subroutine file 'model.for'. C Default: MODEL='model.dat' C Data specifying other input files: C M2IN='string'... Name of the input file containing number M2IN of C values already processed by programs 'invpts.for' or C 'invtt.for', i.e., the name of output file M2 from the C previous execution of 'invpts.for' or 'invtt.for'. C The corresponding output values of this program will be C appended after M1*M2IN input values of file GM1 and after C M2IN input values of files GM2, GM3 and DM1, respectively. C Default: M2IN=' ' means M2IN=0 (no previous values). C PTS='string'... String with the name of the input data file C containing the individual given points with the values to C be fitted by the model. Points situated outside the model C box are not considered. C This program may be executed several times to take into C account several files with individual points, or the same C file with several values at each point (e.g., both P and C S wave velocities at each point). C If the filename is blank, no individual points are given. C Description of file PTS C Default: PTS=' ' C LIN='string'... Alternative to PTS, if the given points are C arranged into lines. Differs from PTS just by the C form of the file. C If the filename is blank, no lines of points are given. C Default: LIN=' ' C GRD='string'... String with the name of the input data file C containing the grided values to be fitted by the model. C The grid may also contain undefined values. C If the whole grid cell centred at a point is situated C outside the model box, the point is not considered. C This program may be executed several times to take into C account several grids of values. C If the filename is blank, no gridded values are assumed. C Default: GRD=' ' C GRDERR='string'... String with the name of the input data file C containing the grided standard deviations of the given C values. C If the filename is blank, unit standard deviations are C assumed. C The standard deviations are multiplied by the value of C ERRMUL, described later on. C Default: GRDERR=' ' C GRDICB='string'... String with the name of the input data file C containing the grided indices of the complex blocks C corresponding to file GRD, if file GRD contains the C material parameters of different complex blocks. C If GRDICB=' ', the index of the surface or complex block C corresponding to file GRD is common for all gridpoints C and is given by parameter INDFUN. C Default: GRDICB=' ' C For general description of the files with gridded data refer to C file forms.htm. C Data specifying output files: C M1='string'... Name of the output file containing number M1 of C model parameters (a single integer). The same file may be C generated by programs 'invsoft.for' and 'invtt.for'. C The file is not generated if the value of M1 is blank. C Default: M1=' ' C Note: Default of 'invsoft.for' is M1='m1.out', C default of 'invtt.for' is M1=' '. C M2='string'... Name of the output file containing number M2 of C accumulated values (a single integer). M2 is M2IN C increased by the number of given values. C The file is not generated if the value of M2 is blank. C Default: M2='m2.out' C Data specifying input/output files with matrix and vector components: C GM1='string'... String with the name of the input/output data file C to accumulate the matrix of the derivatives of M2 given C values with respect to M1 model coefficients. C The matrix has M1*M2IN components on input and M1*M2 C components on output. The formatted file is composed of C real-valued matrix components to be read at once by the C list-directed input. C If the filename is blank, no file is read nor written. C The file is not read, just written if M2IN=0. C Default: GM1=' ' C GM2='string'... String with the name of the input/output data file C containing the vector composed of differences between the C given values and the corresponding values calculated in C the model. The vector has M2IN components on input and M2 C components on output. The formatted file is composed C of real-valued vector components to be read at once by C list-directed input. C If the filename is blank, no file is read nor written. C The file is not read, just written if M2IN=0. C Default: GM2=' ' C GM3='string'... String with the name of the input/output data file C containing the vector composed of the values calculated in C the model. The vector has M2IN components on input and M2 C components on output. The formatted file is composed of C real-valued vector components to be read at once by C list-directed input. C If the filename is blank, no file is read nor written. C The file is not read, just written if M2IN=0. C Default: GM3=' ' C DM1='string'... String with the name of the input/output data file C containing the diagonal matrix composed of the variances C (squares of standard deviations) of the given values. C The diagonal has M2IN components on input and M2 C components on output. The formatted file is composed C of real-valued diagonal components to be read at once by C list-directed input. C If the filename is blank, no file is read nor written. C The file is not read, just written if M2IN=0. C Default: DM1=' ' C For general description of the files with matrices refer to file C forms.htm. C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C Data specifying the function corresponding to the given values: C ICLASS=integer... Class of model parameters to be inverted: C ICLASS=0: All model parameters are inverted. C ICLASS=1: Only model parameters describing interfaces are C inverted. C ICLASS=2: Only model parameters describing material C parameters are inverted. C Default: ICLASS=0 C MPAR=integer... Material parameter corresponding to the given C values. C MPAR=0: The given values correspond to the functions C describing the surfaces covering structural interfaces. C MPAR=positive integer: The given values describe a C material parameter: C MPAR=1: P wave velocity, C MPAR=2: S wave velocity, C MPAR=3: density, C MPAR=4: P wave loss factor, C MPAR=5: S wave loss factor, C MPAR=6 to 26: Reduced (i.e., divided by the density) C anisotropic elastic parameters A11, A12, A22, A13, C A23, A33, A14, A24, A34, A44, A15, A25, A35, A45, A55, C A16, A26, A36, A46, A56 or A66. C MPAR=27-47: Reduced (i.e., divided by the density) C imaginary parts of anisotropic elastic parameters Q11, C Q12, Q22, Q13, Q23, Q33, Q14, Q24, Q34, Q44, Q15, Q25, C Q35, Q45, Q55, Q16, Q26, Q36, Q46, Q56 or Q66. C Default: MPAR=0 C POWERM=real... The given values correspond to the POWERMth power C of the material parameter determined by MPAR. C Default: POWERM=1. C KOLFUN=integer... Specifies the column in input file 'PTS' or C 'LIN' containing the index of the surface (for MPAR=0) or C the complex block. C If KOLFUN=0, the index is common for all points and is C given by parameter INDFUN. C Default: KOLFUN=0 C INDFUN=integer... Index of the surface (for MPAR=0) or of the C complex block to which the given values correspond. C Must be specified and positive if KOLFUN=0 for individual C points or GRDICB=' ' for gridded values. C Default: INDFUN=0 C Data specifying the values to be processed and their accuracy: C KOLUMN=integer... Specifies the column in input file 'PTS' or C 'LIN' containing the given values. Note that the first C 3 columns contain coordinates of the points. C If KOLUMN=0, zero values are assumed (option often used C for the points at interfaces, where the function C describing the corresponding surface should be zero). C Default: KOLUMN=0 C KOLERR=integer... Specifies the column in input file 'PTS' or C 'LIN' containing the standard deviations of the given C values. C If KOLERR=0, unit standard deviations are assumed. C Note that the standard deviations are multiplied by C ERRMUL, described below. C Default: KOLERR=0 C ERRMUL=real... Multiplication factor for the standard deviations C of the given values. Often used with GRDERR=' ' to C specify the standard deviation constant over the grid or C with KOLERR=0 to specify the standard deviation common for C all points. C Default: ERRMUL=1. 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 given values and their standard deviations, C see input parameters KOLUMN, KOLERR and KOLFUN. C /... Values must be terminated by a slash. C (3) / or end of file. 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 given values and their standard deviations, C see input parameters KOLUMN, KOLERR and KOLFUN. 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 INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C Common blocks /MODELC/ and /VALC/: INCLUDE 'model.inc' C model.inc INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C External procedures directly referred: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,RARRAI,RARRAY,WARRAY EXTERNAL LENGTH,MODEL1,SRFC2,PARM2,PARM3,SOFT,VAR6,RMAT,WMAT INTEGER LENGTH C C....................................................................... C C Constants: INTEGER LU1 PARAMETER (LU1=11) REAL UNDEF PARAMETER (UNDEF=-9.999E9) C C Filenames: CHARACTER*80 FILE1 C C Data: INTEGER N1,N2,N3,M1,M2,M2IN INTEGER ICLASS,MPAR,KOLUMN,KOLERR,KOLFUN,INDFUN REAL D1,D2,D3,O1,O2,O3,POWERM,ERRMUL C C Other variables: CHARACTER*1 TEXT INTEGER N1N2N3,KOLMAX,NFREE,NUNDEF,NOFF,NPTS6,NFUN INTEGER I,I1,I2,I3,J1,J2,J3,K1,K2,K3 REAL F(10,47),W(47,2),POWER(47),X1,X2,X3,B0I,AUX,CS(1) EQUIVALENCE (F(1,1),W(1,1)) C C Usage of RAM: C RAM(1:6*NPTS): C RAM(1,*)=X1 C RAM(2,*)=X2 C RAM(3,*)=X3 C RAM(4,*)=given value, later given minus reference value C IRAM(4,*)=MPAR, later RAM(4,*)=reference value C RAM(6,*)=standard deviation, later the variance C RAM(6*NPTS+1:6*NPTS+M1*M2): Derivatives C RAM(6*NPTS+M1*M2+1:6*NPTS+M1*M2+M1): Indices of model coefficients C C----------------------------------------------------------------------- C C Opening data files and reading the input data: C C Reading main input data: WRITE(*,'(A)') '+INVPTS: Enter input filename: ' FILE1=' ' READ (*,*) FILE1 IF(FILE1.EQ.' ') THEN C INVPTS-01 CALL ERROR('INVPTS-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)') '+INVPTS: Working... ' CALL RSEP1(LU1,FILE1) C C Reading input data for the model: CALL RSEP3T('MODEL' ,FILE1 ,'model.dat') OPEN(LU1,FILE=FILE1,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) C C Reading input parameters describing the input values: CALL RSEP3I('KOLUMN',KOLUMN,0) CALL RSEP3I('KOLERR',KOLERR,0) CALL RSEP3I('KOLFUN',KOLFUN,0) CALL RSEP3I('INDFUN',INDFUN,0) KOLMAX=MAX0(3,KOLUMN,KOLERR,KOLFUN) C C....................................................................... C C Reading the points: C C Number of valid points NPTS6=0 C Number of points with zero indeces (e.g., situated in free space) NFREE=0 C Number of points with positive indices but undefined values NUNDEF=0 C Number of defined points with positive indices outside the model NOFF=0 C C Reading gridded values: CALL RSEP3T('GRD',FILE1 ,' ') IF(FILE1.NE.' ') THEN 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.) CALL RSEP3R('O1',O1,0.) CALL RSEP3R('O2',O2,0.) CALL RSEP3R('O3',O3,0.) N1N2N3=N1*N2*N3 IF(6*N1N2N3.GT.MRAM) THEN GO TO 99 END IF CALL RARRAY(LU1,FILE1,'FORMATTED',.TRUE.,UNDEF,N1N2N3,RAM(1)) C Reading indices of surfaces or complex blocks CALL RSEP3T('GRDICB',FILE1 ,' ') IF(FILE1.EQ.' '.AND.INDFUN.LE.0) THEN C INVPTS-03 CALL ERROR('INVPTS-03: Neither GRDICB nor INDFUN specified') C See the description of the input data. END IF IF(FILE1.EQ.' ') THEN DO 11 I=N1N2N3+1,2*N1N2N3 IRAM(I)=INDFUN 11 CONTINUE ELSE CALL RARRAI(LU1,FILE1,'FORMATTED',.TRUE.,0, * N1N2N3,IRAM(N1N2N3+1)) END IF C Reading errors CALL RSEP3T('GRDERR',FILE1 ,' ') IF(FILE1.EQ.' ') THEN DO 12 I=2*N1N2N3+1,3*N1N2N3 RAM(I)=1. 12 CONTINUE ELSE CALL RARRAY(LU1,FILE1,'FORMATTED',.TRUE.,1., * N1N2N3,RAM(2*N1N2N3+1)) END IF C Rearranging the values in the memory DO 13 I=N1N2N3+1,2*N1N2N3 RAM (3*I-2)=RAM (I-N1N2N3) IRAM(3*I-1)=IRAM(I ) RAM (3*I )=RAM (I+N1N2N3) 13 CONTINUE C Removing undefined values and values outside the model J1=NINT((BOUNDM(1)-O1)/D1) K1=NINT((BOUNDM(2)-O1)/D1) J2=NINT((BOUNDM(3)-O2)/D2) K2=NINT((BOUNDM(4)-O2)/D2) J3=NINT((BOUNDM(5)-O3)/D3) K3=NINT((BOUNDM(6)-O3)/D3) I=3*N1N2N3 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+3 IF(IRAM(I-1).LE.0) THEN NFREE=NFREE+1 ELSE IF(RAM(I-2).EQ.UNDEF) THEN NUNDEF=NUNDEF+1 ELSE IF(J3.LE.I3.AND.I3.LE.K3) THEN IF(J2.LE.I2.AND.I2.LE.K2) THEN IF(J1.LE.I1.AND.I1.LE.K1) THEN RAM (NPTS6+1)=X1 RAM (NPTS6+2)=X2 RAM (NPTS6+3)=X3 RAM (NPTS6+4)=RAM (I-2) IRAM(NPTS6+5)=IRAM(I-1) RAM (NPTS6+6)=RAM (I ) NPTS6=NPTS6+6 END IF END IF END IF END IF 21 CONTINUE 22 CONTINUE 23 CONTINUE NOFF=N1N2N3-NFREE-NUNDEF-NPTS6/6 END IF C C Reading individual points: CALL RSEP3T('PTS',FILE1 ,' ') IF(FILE1.NE.' ') THEN IF(KOLFUN.LE.0.AND.INDFUN.LE.0) THEN C INVPTS-04 CALL ERROR('INVPTS-04: Neither KOLFUN nor INDFUN specified') C See the description of the input data. END IF OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*,END=39) (TEXT,I=1,20) C Loop over points 31 CONTINUE IF(NPTS6+3+KOLMAX.GT.MRAM) THEN GO TO 99 END IF TEXT='$' X1=0. X2=0. X3=0. READ(LU1,*,END=39) TEXT,X1,X2,X3, * (RAM(I),I=NPTS6+7,NPTS6+3+KOLMAX) IF(TEXT.EQ.'$') THEN GO TO 39 END IF NOFF=NOFF+1 IF(BOUNDM(1).LE.X1.AND.X1.LE.BOUNDM(2)) THEN IF(BOUNDM(3).LE.X2.AND.X2.LE.BOUNDM(4)) THEN IF(BOUNDM(5).LE.X3.AND.X3.LE.BOUNDM(6)) THEN RAM(NPTS6+1)=X1 RAM(NPTS6+2)=X2 RAM(NPTS6+3)=X3 IF(KOLUMN.GT.0) THEN RAM(NPTS6+4)=RAM(NPTS6+3+KOLUMN) ELSE RAM(NPTS6+4)=0. END IF IF(KOLFUN.GT.0) THEN IRAM(NPTS6+5)=NINT(RAM(NPTS6+3+KOLFUN)) ELSE IRAM(NPTS6+5)=INDFUN END IF IF(KOLERR.GT.0) THEN RAM(NPTS6+6)=RAM(NPTS6+3+KOLERR) ELSE RAM(NPTS6+6)=1. END IF NPTS6=NPTS6+6 NOFF=NOFF-1 END IF END IF END IF GO TO 31 C End of the loop over points 39 CONTINUE CLOSE(LU1) END IF C C Reading the lines of points: CALL RSEP3T('LIN',FILE1 ,' ') IF(FILE1.NE.' ') THEN IF(KOLFUN.LE.0.AND.INDFUN.LE.0) THEN C INVPTS-05 CALL ERROR('INVPTS-05: Neither KOLFUN nor INDFUN specified') C See the description of the input data. END IF OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*,END=49) (TEXT,I=1,20) C Loop over lines 41 CONTINUE TEXT='$' READ(LU1,*,END=90) TEXT,AUX,AUX,AUX IF(TEXT.EQ.'$') THEN GO TO 49 END IF C Loop over points 42 CONTINUE IF(NPTS6+3+KOLMAX.GT.MRAM) THEN GO TO 99 END IF X1=UNDEF X2=0. X3=0. READ(LU1,*,END=49) TEXT,X1,X2,X3, * (RAM(I),I=NPTS6+7,NPTS6+3+KOLMAX) IF(X1.EQ.UNDEF) THEN C End of the line GO TO 48 END IF NOFF=NOFF+1 IF(BOUNDM(1).LE.X1.AND.X1.LE.BOUNDM(2)) THEN IF(BOUNDM(3).LE.X2.AND.X2.LE.BOUNDM(4)) THEN IF(BOUNDM(5).LE.X3.AND.X3.LE.BOUNDM(6)) THEN RAM(NPTS6+1)=X1 RAM(NPTS6+2)=X2 RAM(NPTS6+3)=X3 IF(KOLUMN.GT.0) THEN RAM(NPTS6+4)=RAM(NPTS6+3+KOLUMN) ELSE RAM(NPTS6+4)=0. END IF IF(KOLFUN.GT.0) THEN IRAM(NPTS6+5)=NINT(RAM(NPTS6+3+KOLFUN)) ELSE IRAM(NPTS6+5)=INDFUN END IF IF(KOLERR.GT.0) THEN RAM(NPTS6+6)=RAM(NPTS6+3+KOLERR) ELSE RAM(NPTS6+6)=1. END IF NPTS6=NPTS6+6 NOFF=NOFF-1 END IF END IF END IF GO TO 42 C End of the loop over points 48 CONTINUE GO TO 41 C End of the loop over lines 49 CONTINUE CLOSE(LU1) END IF C C....................................................................... C C Matrix dimensions: C C Reading number of points processed previously: M2IN=0 CALL RSEP3T('M2IN',FILE1,' ') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M2IN CLOSE(LU1) END IF C C Writing the total number of points: M2=M2IN+NPTS6/6 CALL RSEP3T('M2',FILE1,'m2.out') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1) WRITE(LU1,'(I10)') M2 CLOSE(LU1) END IF C C Number of unknown model parameters: CALL RSEP3I('ICLASS',ICLASS,0) IF(ICLASS.LT.0.OR.2.LT.ICLASS) THEN C INVPTS-06 CALL ERROR('INVPTS-06: Incorrect class index ICLASS') C The value of ICLASS must be 0, 1 or 2. C Check the input data. END IF DO 51 I=1,47 W(I,1)=0. W(I,2)=0. 51 CONTINUE M1=0 IF(ICLASS.LE.1) THEN CALL SOFT(1,0,0,0,0,0,0,47,W,M1,IRAM(NPTS6+1),CS(1),1,CS(1)) END IF IF(ICLASS.EQ.0.OR.ICLASS.EQ.2) THEN CALL SOFT(2,0,0,0,0,0,0,47,W,M1,IRAM(NPTS6+1),CS(1),1,CS(1)) END IF IF(NPTS6+M1*M2+M1.GT.MRAM) THEN GO TO 99 END IF I1=0 IF(ICLASS.LE.1) THEN CALL SOFT(1,0,0,0,0,0,0,47,W,I1,IRAM(NPTS6+M1*M2+1), * CS(1),1,CS(1)) END IF IF(ICLASS.EQ.0.OR.ICLASS.EQ.2) THEN CALL SOFT(2,0,0,0,0,0,0,47,W,I1,IRAM(NPTS6+M1*M2+1), * CS(1),1,CS(1)) END IF CALL RSEP3T('M1',FILE1,' ') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1) WRITE(LU1,'(I10)') M1 CLOSE(LU1) END IF C C Information written to the screen: IF(NFREE.GT.0) THEN WRITE(*,'(A,I8,A)')'+INVPTS:',NFREE,' gridpoints in free space,' WRITE(*,'(A)') ' INVPTS: Working...' END IF IF(NUNDEF.GT.0) THEN WRITE(*,'(A,I8,A)') '+INVPTS:',NUNDEF,' undefined grid values,' WRITE(*,'(A)') ' INVPTS: Working...' END IF IF(NOFF.GT.0) THEN WRITE(*,'(A,I8,A)') '+INVPTS:',NOFF,' points outside model,' WRITE(*,'(A)') ' INVPTS: Working...' END IF C C....................................................................... C C Calculating the functional values and the derivatives with respect C to the model coefficients at the stored points: C CALL RSEP3I('MPAR' ,MPAR ,0) IF(MPAR.LT.0.OR.47.LT.MPAR) THEN C INVPTS-07 CALL ERROR('INVPTS-07: Wrong material parameter') C Material parameters are indexed by integers from 1 to 47, C but index greater than 47 has been encountered. C Check the input data. END IF CALL RSEP3R('POWERM',POWERM,1.) CALL RSEP3R('ERRMUL',ERRMUL,1.) C C Loop over the points: DO 69 I3=0,NPTS6-6,6 IF((ICLASS.LE.1.AND.MPAR.LE.0).OR. * ((ICLASS.EQ.0.OR.ICLASS.EQ.2).AND.MPAR.GE.1)) THEN C Evaluation of the function: IF(MPAR.LE.0) THEN C Functions describing surfaces: C CALL SRFC2(IRAM(I3+5),RAM(I3+1),F) CALL VAL2(1,IRAM(I3+5),1,RAM(I3+1),F,POWER) RAM(I3+4)=RAM(I3+4)-F(1,1) RAM(I3+5)=F(1,1) ELSE C Material parameters: CALL VAL2(2,IRAM(I3+5),47,RAM(I3+1),F,POWER) AUX=POWER(MPAR)/POWERM IF(AUX.NE.1.) THEN C Power of the given value RAM(I3+4)=RAM(I3+4)**AUX C Standard deviation of the power RAM(I3+6)=RAM(I3+6)*AUX*RAM(I3+4)**(AUX-1.) END IF RAM(I3+4)=RAM(I3+4)-F(1,MPAR) RAM(I3+5)=F(1,MPAR) END IF C C Variance (square of the standard deviation): RAM(I3+6)=(RAM(I3+6)*ERRMUL)**2 C C Derivatives of the function with respect to model coefficients: DO 61 I1=NPTS6+M1*(M2IN+I3/6)+1,NPTS6+M1*(M2IN+I3/6)+M1 RAM(I1)=0. 61 CONTINUE I2=0 62 CONTINUE I2=I2+1 CALL VAR6(MAX0(1,MPAR),I2,NFUN,I,B0I,AUX,AUX,AUX) IF(I2.LE.NFUN) THEN DO 63 I1=NPTS6+M1*M2+1,NPTS6+M1*M2+M1 IF(I.EQ.IRAM(I1)) THEN RAM(M1*(I3-NPTS6)/6+I1)=B0I GO TO 64 END IF 63 CONTINUE C INVPTS-08 CALL ERROR * ('INVPTS-08: Incorrect index of model parameter') 64 CONTINUE END IF IF(I2.LT.NFUN) GO TO 62 C END IF 69 CONTINUE C C....................................................................... C C Writing output files: C C Writing the derivatives: CALL RSEP3T('GM1',FILE1 ,' ') IF(FILE1.NE.' ') THEN IF (M2IN.GT.0) THEN CALL RMAT(LU1,FILE1,M1,M2IN,RAM(NPTS6+1)) END IF CALL WMAT(LU1,FILE1,M1,M2,RAM(NPTS6+1)) END IF C C Writing the given values minus the reference values: CALL RSEP3T('GM2',FILE1 ,' ') IF(FILE1.NE.' ') THEN IF(M2IN.GT.0) THEN CALL RMAT(LU1,FILE1,M2IN,1,RAM(NPTS6+1)) END IF DO 81 I=1,NPTS6/6 RAM(NPTS6+M2IN+I)=RAM(6*I-2) 81 CONTINUE CALL WMAT(LU1,FILE1,M2,1,RAM(NPTS6+1)) END IF C C Writing the reference values: CALL RSEP3T('GM3',FILE1 ,' ') IF(FILE1.NE.' ') THEN IF(M2IN.GT.0) THEN CALL RMAT(LU1,FILE1,M2IN,1,RAM(NPTS6+1)) END IF DO 82 I=1,NPTS6/6 RAM(NPTS6+M2IN+I)=RAM(6*I-1) 82 CONTINUE CALL WMAT(LU1,FILE1,M2,1,RAM(NPTS6+1)) END IF C C Writing the variances: CALL RSEP3T('DM1',FILE1 ,' ') IF(FILE1.NE.' ') THEN IF(M2IN.GT.0) THEN CALL RMAT(LU1,FILE1,M2IN,1,RAM(NPTS6+1)) END IF DO 83 I=1,NPTS6/6 RAM(NPTS6+M2IN+I)=RAM(6*I) 83 CONTINUE CALL WMAT(LU1,FILE1,M2,1,RAM(NPTS6+1)) END IF C 90 CONTINUE WRITE(*,'(A,I8,A)') '+INVPTS:',NPTS6/6,' points processed.' STOP C 99 CONTINUE C INVPTS-02 CALL ERROR('INVPTS-02: Too small dimension MRAM of array RAM') C Dimension MRAM of array RAM in include file C ram.inc should be increased. C MRAM should be MAX(6*N1*N2*N3,6*NPTS+M1*M2+M1) at the least. C Here NPTS=M2-M2IN is the number of valid points, i.e., of points C situated inside the model box, with defined given values. 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 'modelv.for' C modelv.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parmv.for' C parmv.for INCLUDE 'valv.for' C valv.for INCLUDE 'fitv.for' C fitv.for INCLUDE 'var.for' C var.for INCLUDE 'soft.for' C soft.for INCLUDE 'spsp.for' C spsp.for C C======================================================================= Cinvsoft.for 0100666 0000765 0000765 00000055354 07305626410 012650 0 ustar bulant bulant C
C Program INVSOFT to evaluate the coefficients of the soft subjective C a priori information on the perturbations of the model parameters. C The subjective a priori information is composed of the squares of the C Sobolev norms of the functions describing the model. 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 Program INVSOFT assumes all model parameters (coefficients) stored in C the common block /VALC/ as in the submitted versions of user-defined C model specification FORTRAN77 source code files 'srfc.for', 'parm.for' C and 'val.for'. Thus, unlike the other parts of the complete ray C tracing, the INVSOFT program cannot work with user's modifications of C subroutines SRFC1, SRFC2, PARM1, and PARM2. 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 MODEL='string'... String containing the name of the input data C file specifying the model. For description of the data C file refer to file 'model.for' of package MODEL. C Description of file MODEL C Default: MODEL='model.dat' C SOBOLEV='string'... String containing the name of the input data C file containing the coefficients describing the Sobolev C scalar product under consideration. C The file is not read if MODSOB=' ', see below. Otherwise, C the filename should be specified. C Description of file SOBOLEV C Default: SOBOLEV=' ' C Weighting factors of surfaces and material parameters: C SOBW00=real... Square root of the multiplication factor of the L2 C and Sobolev scalar products corresponding to the functions C describing the surfaces. C Default: SOBW00=0. C SOBW01=real... Square root of the multiplication factor of the L2 C and Sobolev scalar products corresponding to the C interpolated power of the P wave velocity. C Default: SOBW01=0. C SOBW02=real... Analogue corresponding to the S wave velocity. C Default: SOBW02=0. C SOBW03=real... Analogue corresponding to the density. C Default: SOBW03=0. C SOBW04=real... Analogue corresponding to the P wave loss factor. C Default: SOBW04=0. C SOBW05=real... Analogue corresponding to the S wave loss factor. C Default: SOBW05=0. C SOBW06=real to SOBW26=real... Analogues corresponding to the C reduced (i.e., divided by the density) anisotropic elastic C parameters A11, A12, A22, A13, A23, A33, A14, A24, A34, C A44, A15, A25, A35, A45, A55, A16, A26, A36, A46, A56 and C A66. C Defaults: SOBW06=0. to SOBW26=0. C SOBW27=real to SOBW47=real... Analogues corresponding to the C reduced (i.e., divided by the density) imaginary parts of C anisotropic elastic parameters Q11, Q12, Q22, Q13, Q23, C Q33, Q14, Q24, Q34, Q44, Q15, Q25, Q35, Q45, Q55, Q16, C Q26, Q36, Q46, Q56 and Q66. C Defaults: SOBW27=0. to SOBW47=0. C Data specifying output files: C M1='string'... Name of the output file containing the number NM of C model parameters (a single integer). The same file may be C generated by programs 'invpts.for' and 'invtt.for'. C The file is not generated if the value of M1 is blank. C Default: M1='m1.out' C Note: Default of 'invpts.for' and 'invtt.for' is M1=' '. C MODIND='string'... Name of the output file containing the indices C of model coefficients. The indices correspond to the C relative location in the memory. B-spline coefficients C are listed in the same order as the grid values in input C file MODEL. C The file is not generated if the value of MODIND is blank. C File MODIND is read by program 'modmod.for' when updating C the model. C The file has the form integer vector of NM components. C Description of file MODIND C Default: MODIND='modind.out' C MODPAR='string'... Name of the output file containing the values C of model parameters (coefficients at the model basis C functions). C The file is not generated if the value of MODPAR is blank. C The file has the form real-valued vector of NM components. C Description of file MODPAR C Default: MODPAR=' ' C MODL2='string'... Name of the output file containing the symmetric C positive-definite matrix of L2 scalar products of the C model basis functions. C The file is not generated if the value of MODL2 is blank. C Description of file MODL2 C Default: MODL2=' ' C MODSOB='string'... Name of the output file containing the C symmetric positive-semidefinite matrix of Sobolev scalar C products of the model basis functions. The particular C kind of the Sobolev scalar product is given by input file C SOBOLEV. C The file is not generated if the value of MODSOB is blank. C Description of file MODSOB C Default: MODSOB=' ' C Form of the files with matrices: C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMW='string' ... Form of the files with matrices to be written. C Default: FORMMW=FORMM C Optional data specifying the class of functions: C ICLASS=integer... Class of model parameters to be inverted: C ICLASS=0: All model parameters are inverted. C ICLASS=1: Only model parameters describing interfaces are C inverted. C ICLASS=2: Only model parameters describing material C parameters are inverted. C Default: ICLASS=0 C C C Input data SOBOLEV: C This data file contains the coefficients describing the Sobolev C scalar product under consideration. C (1) (NW1(I),NW2(I),NW3(I),I=1,NW),/ C List of partial derivatives included in the Sobolev scalar product C which is assumed to represent subjective prior information about C the model, terminated by a slash. C NW1,NW2,NW3... Orders of partial derivatives with respect to C X1,X2,X3 coordinates. For (bi-,tri-)cubic splines, the C third homogeneous partial derivatives are discontinuous. C NWi thus should not exceed 3, allowing for 64 different C partial derivatives at the most. C (2) ((WCS(I,J),I=1,J),J=1,NW) C Elements of the constant symmetric weighting matrix of the Sobolev C scalar product. C WCS(I,J)... Coefficient of the product of C (NW1(I),NW2(I),NW3(I))-th and (NW1(J),NW2(J),NW3(J))-th C partial derivatives of functions in the Sobolev scalar C product. The product of the derivatives is integrated C over the volume (surface, length) of the spline grid and C divided by the volume (surface, length) of the grid to C yield the average value of the product of the derivatives, C The average value is multiplied by WCS(I,J) to form the C contribution to the Sobolev scalar product. C Example of data SOBOLEV C C C Output file MODIND: C (1) (INDM(I),I=1,NM),/ C INDM... Indices of the model parameters considered by this C program. The indices correspond to the relative location C in the memory, in array RPAR of common block /VALC/. C B-spline coefficients are listed in the same order as the C grid velocities in file MODEL. C Common block /VALC/ C C C Output file MODPAR: C (1) (RS(I),I=1,NM) C RS... Parameters (coefficients) of the input model. C C C Output file MODL2: C (1) For each column J=1,NM: C (1.1) (BL2(I,J),I=1,J): C BL2... Symmetric matrix of the L2 scalar products of the basis C functions corresponding to the model parameters. C C C Output file MODSOB: C (1) For each column J=1,NM: C (1.1) (BSOB(I,J),I=1,J): C BSOB... Symmetric matrix of the Sobolev scalar products of the C basis functions corresponding to the model parameters. C C----------------------------------------------------------------------- C C Common block /VALC/: INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (RAM,IRAM) C C----------------------------------------------------------------------- C C Filenames: CHARACTER*80 FILE1,FILE2 C C Logical unit number: INTEGER LU1 PARAMETER (LU1=1) C INTEGER ICLASS,NW,NM C NW... Number of specified partial derivatives. C NM... Number of the unknown model parameters. C C Addresses in array RAM: INTEGER IWCS0,INDM0,ICS0,IB0 C IRAM(1:3),IRAM(4:6),...,IRAM(3*NW-2:3*NW)... Orders of partial C derivatives. C IWCS0=3*NW... Origin of array WCS(I,J) of the weights describing C the Sobolev scalar product. C INDM0=IWCS0+NW*(NW+1)/2... Origin of array INDM of the indices of C model parameters. C ICS0=INDM0+NM... Origin of symmetric matrix CS of the Sobolev C scalar products of the basis functions corresponding to C the model parameters. C IB0=ICS0+NM*(NM+1)/2... Origin of the working array. C INTEGER MW,I,J,K REAL SOBW(47,2),WEIGHT(47,2),W C C....................................................................... C C Opening data files and reading the input data: C C Main input data file read from the interactive device (*): WRITE(*,'(A)') '+INVSOFT: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF(FILE1.EQ.' ') THEN C INVSOFT-01 CALL ERROR('INVSOFT-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)') '+INVSOFT: Working... ' C C Reading main input data file: CALL RSEP1(LU1,FILE1) C C Reading input data MODEL for the model: CALL RSEP3T('MODEL',FILE1,'model.dat') OPEN(LU1,FILE=FILE1,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) C DO 11 I=1,47 SOBW(I,1)=0. WEIGHT(I,1)=0. WEIGHT(I,2)=0. 11 CONTINUE CALL RSEP3R('SOBW00',SOBW(01,1),0.) CALL RSEP3R('SOBW01',SOBW(01,2),0.) CALL RSEP3R('SOBW02',SOBW(02,2),0.) CALL RSEP3R('SOBW03',SOBW(03,2),0.) CALL RSEP3R('SOBW04',SOBW(04,2),0.) CALL RSEP3R('SOBW05',SOBW(05,2),0.) CALL RSEP3R('SOBW06',SOBW(06,2),0.) CALL RSEP3R('SOBW07',SOBW(07,2),0.) CALL RSEP3R('SOBW08',SOBW(08,2),0.) CALL RSEP3R('SOBW09',SOBW(09,2),0.) CALL RSEP3R('SOBW10',SOBW(10,2),0.) CALL RSEP3R('SOBW11',SOBW(11,2),0.) CALL RSEP3R('SOBW12',SOBW(12,2),0.) CALL RSEP3R('SOBW13',SOBW(13,2),0.) CALL RSEP3R('SOBW14',SOBW(14,2),0.) CALL RSEP3R('SOBW15',SOBW(15,2),0.) CALL RSEP3R('SOBW16',SOBW(16,2),0.) CALL RSEP3R('SOBW17',SOBW(17,2),0.) CALL RSEP3R('SOBW18',SOBW(18,2),0.) CALL RSEP3R('SOBW19',SOBW(19,2),0.) CALL RSEP3R('SOBW20',SOBW(20,2),0.) CALL RSEP3R('SOBW21',SOBW(21,2),0.) CALL RSEP3R('SOBW22',SOBW(22,2),0.) CALL RSEP3R('SOBW23',SOBW(23,2),0.) CALL RSEP3R('SOBW24',SOBW(24,2),0.) CALL RSEP3R('SOBW25',SOBW(25,2),0.) CALL RSEP3R('SOBW26',SOBW(26,2),0.) CALL RSEP3R('SOBW27',SOBW(27,2),0.) CALL RSEP3R('SOBW28',SOBW(28,2),0.) CALL RSEP3R('SOBW29',SOBW(29,2),0.) CALL RSEP3R('SOBW30',SOBW(30,2),0.) CALL RSEP3R('SOBW31',SOBW(31,2),0.) CALL RSEP3R('SOBW32',SOBW(32,2),0.) CALL RSEP3R('SOBW33',SOBW(33,2),0.) CALL RSEP3R('SOBW34',SOBW(34,2),0.) CALL RSEP3R('SOBW35',SOBW(35,2),0.) CALL RSEP3R('SOBW36',SOBW(36,2),0.) CALL RSEP3R('SOBW37',SOBW(37,2),0.) CALL RSEP3R('SOBW38',SOBW(38,2),0.) CALL RSEP3R('SOBW39',SOBW(39,2),0.) CALL RSEP3R('SOBW40',SOBW(40,2),0.) CALL RSEP3R('SOBW41',SOBW(41,2),0.) CALL RSEP3R('SOBW42',SOBW(42,2),0.) CALL RSEP3R('SOBW43',SOBW(43,2),0.) CALL RSEP3R('SOBW44',SOBW(44,2),0.) CALL RSEP3R('SOBW45',SOBW(45,2),0.) CALL RSEP3R('SOBW46',SOBW(46,2),0.) CALL RSEP3R('SOBW47',SOBW(47,2),0.) SOBW(1,1)=SOBW(1,1)*SOBW(1,1) DO 12 I=1,47 SOBW(I,2)=SOBW(I,2)*SOBW(I,2) 12 CONTINUE C C Number and indices of unknown model parameters: CALL RSEP3I('ICLASS',ICLASS,0) IF(ICLASS.LT.0.OR.2.LT.ICLASS) THEN C INVPTS-05 CALL ERROR('INVPTS-05: Incorrect class index ICLASS') C The value of ICLASS must be 0, 1 or 2. C Check the input data. END IF INDM0=0 NM=0 IF(ICLASS.LE.1) THEN CALL SOFT(1,0,0,0,0,0,0,47,WEIGHT,NM,IRAM(INDM0+1),RAM,1,RAM) END IF IF(ICLASS.EQ.0.OR.ICLASS.EQ.2) THEN CALL SOFT(2,0,0,0,0,0,0,47,WEIGHT,NM,IRAM(INDM0+1),RAM,1,RAM) END IF C (Last two actual arguments RAM are not used since WEIGHT(*,*)=0.) C (We have just hoped here that array IRAM is sufficiently large.) C WRITE(*,'(A,I5,A)') '+INVSOFT:',NM,' model parameters' ICS0=INDM0+NM IB0=ICS0+NM*(NM+1)/2 IF(IB0.GE.MRAM) THEN C INVSOFT-06 CALL ERROR('INVSOFT-06: Too small array RAM') C Dimension MRAM of array RAM in include file C ram.inc C should be increased to accommodate the indices of model C parameters, the output symmetric matrix CS of subroutine SOFT C containing the L2 scalar products of the basis functions C corresponding to the model parameters, and working array B of C subroutine SOFT. C Consider simultaneously the memory requirement described at C error INVSOFT-08. END IF C C Writing output file M1: CALL RSEP3T('M1',FILE1,'m1.out') IF(FILE1.NE.' ') THEN I=MAX0(INDEX(FILE1,' ')-1,11) WRITE(*,'(2A)') '+INVSOFT: Writing file ',FILE1(1:I) OPEN(LU1,FILE=FILE1) WRITE(LU1,'(I10)') NM CLOSE(LU1) END IF C C Writing output file MODIND: CALL RSEP3T('MODIND',FILE1,'modind.out') IF(FILE1.NE.' ') THEN I=MAX0(INDEX(FILE1,' ')-1,11) WRITE(*,'(2A)') '+INVSOFT: Writing file ',FILE1(1:I) OPEN(LU1,FILE=FILE1) WRITE(LU1,'(10(I7,1X))') (IRAM(I),I=INDM0+1,INDM0+NM) CLOSE(LU1) END IF C C Writing output file MODPAR: CALL RSEP3T('MODPAR',FILE1,' ') IF(FILE1.NE.' ') THEN IF(INDM0+2*NM.GE.MRAM) THEN C INVSOFT-07 CALL ERROR('INVSOFT-07: Too small array RAM') C Dimension MRAM of array RAM in include file C ram.inc C should be increased to accommodate the input coefficients of C the Sobolev scalar product, the indices of model parameters, C and if MODPAR is not blank, also the values of model C parameters. C Consider simultaneously the memory requirements described at C errors INVSOFT-06 C and INVSOFT-08. END IF DO 13 I=INDM0+1,INDM0+NM RAM(I+NM)=RPAR(IRAM(I)) 13 CONTINUE CALL WMAT(LU1,FILE1,NM,1,RAM(INDM0+NM+1)) END IF C C Calculating and writing the L2 scalar products: CALL RSEP3T('MODL2',FILE1,' ') IF(FILE1.NE.' ') THEN WRITE(*,'(A)') '+INVSOFT: Calculating L2 scalar products' DO 14 I=ICS0+1,IB0 RAM(I)=0. 14 CONTINUE NM=0 IF(ICLASS.LE.1) THEN CALL SOFT(1,0,0,0,0,0,0,47,SOBW, * NM,IRAM(INDM0+1),RAM(ICS0+1),MRAM-IB0,RAM(IB0+1)) END IF IF(ICLASS.EQ.0.OR.ICLASS.EQ.2) THEN CALL SOFT(2,0,0,0,0,0,0,47,SOBW, * NM,IRAM(INDM0+1),RAM(ICS0+1),MRAM-IB0,RAM(IB0+1)) END IF CALL WMAT(LU1,FILE1,NM,0,RAM(ICS0+1)) END IF C C....................................................................... C CALL RSEP3T('MODSOB',FILE1,' ') IF(FILE1.NE.' ') THEN C C Input data SOBOLEV: CALL RSEP3T('SOBOLEV',FILE2,' ') IF(FILE2.EQ.' ') THEN C INVSOFT-02 CALL ERROR('INVSOFT-02: No input file SOBOLEV specified') C If parameter MODSOB is not blank, parameter SOBOLEV must be C specified and not blank. There is no default filename. C See the input data. END IF I=MAX0(INDEX(FILE2,' ')-1,11) WRITE(*,'(2A)') '+INVSOFT: Reading file ',FILE2(1:I) OPEN(LU1,FILE=FILE2,STATUS='OLD') C Reading prior subjective information coefficients: C Maximum number MW of different partial derivatives MW=MIN0(64,(MRAM-1)/3) DO 21 I=1,3*MW+1 IRAM(I)=-1 21 CONTINUE READ(LU1,*) (IRAM(I),I=1,3*MW+1) DO 22 I=1,3*MW+1 IF(IRAM(I).LT.0) THEN NW=(I-1)/3 IF(3*NW.NE.I-1) THEN C INVSOFT-03 CALL ERROR('INVSOFT-03: Wrong partial derivatives') C The input partial derivatives do not form triplets, C or some of the derivatives is of a negative order. END IF GO TO 23 END IF 22 CONTINUE C INVSOFT-04 CALL ERROR('INVSOFT-04: Too many partial derivatives') C The number of input triplets of partial derivatives is greater C than the maximum number MW defined few lines above. 23 CONTINUE IWCS0=3*NW INDM0=IWCS0+NW*(NW+1)/2 ICS0=INDM0+NM IB0=ICS0+NM*(NM+1)/2 IF(IB0.GE.MRAM) THEN C INVSOFT-08 CALL ERROR('INVSOFT-08: Too small array RAM') C Dimension MRAM of array RAM in include file C ram.inc C should be increased to accommodate the input coefficients of C the Sobolev scalar product, the indices of model parameters, C the output symmetric matrix CS of subroutine SOFT containing C the Sobolev scalar products of the basis functions C corresponding to the model parameters, and working array B of C subroutine SOFT. END IF READ(LU1,*) (RAM(I),I=IWCS0+1,INDM0) CLOSE(LU1) C C Generating the Sobolev scalar products: WRITE(*,'(A)') '+INVSOFT: Calculating Sobolev scalar products' DO 51 I=ICS0+1,IB0 RAM(I)=0. 51 CONTINUE DO 59 J=1,NW DO 58 I=1,J W=RAM(IWCS0+J*(J-1)/2+I) IF(W.NE.0.) THEN WEIGHT(1,1)=SOBW(1,1)*W DO 52 K=1,47 WEIGHT(K,2)=SOBW(K,2)*W 52 CONTINUE NM=0 IF(ICLASS.LE.1) THEN CALL SOFT(1,IRAM(3*I-2),IRAM(3*I-1),IRAM(3*I), * IRAM(3*J-2),IRAM(3*J-1),IRAM(3*J),47,WEIGHT, * NM,IRAM(INDM0+1),RAM(ICS0+1),MRAM-IB0,RAM(IB0+1)) END IF IF(ICLASS.EQ.0.OR.ICLASS.EQ.2) THEN CALL SOFT(2,IRAM(3*I-2),IRAM(3*I-1),IRAM(3*I), * IRAM(3*J-2),IRAM(3*J-1),IRAM(3*J),47,WEIGHT, * NM,IRAM(INDM0+1),RAM(ICS0+1),MRAM-IB0,RAM(IB0+1)) END IF END IF 58 CONTINUE 59 CONTINUE C C Writing output file MODSOB: CALL WMAT(LU1,FILE1,NM,0,RAM(ICS0+1)) END IF C WRITE(*,'(A)') '+INVSOFT: 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for INCLUDE 'spsp.for' C spsp.for INCLUDE 'soft.for' C soft.for C C======================================================================= Cmeans.for 0100666 0000765 0000765 00000105111 06717724556 012266 0 ustar bulant bulant C
C Subroutine file 'means.for' containing some utility programs helpful C when dealing with the model. C C Date: 1999, May 17 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C CDE... Subroutine designed to search for the point of C intersection of the given curve with the boundaries of the C complex block. The curve is interpolated from the two C given points. The subroutine performs the steps 5.8.3(c), C (d) and (e) of the algorithm. C CDE C CROSS...Subroutine designed to find the point of intersection of a C curve with a surface (see C.R.T.5.8.4b). C CROSS C HIVD2...Subroutine performing the Hermite interpolation of a C vector and its derivatives using functional values and C derivatives at 2 given points (see C.R.T.5.8.4a). C HIVD2 C SMVPRD..Subroutine designed to evaluate symmetric matrix by vector C product. It may be, e.g., called after the invocation of C the METRIC subroutine to transform the covariant vectors C to the contravariant ones and vice versa. C SMVPRD C C======================================================================= C C C SUBROUTINE CDE(NOUGHT,NEND,KEND,NBOUND,KBOUND,BOUND, * KDIM1,KDIM2,NDIM,IY,ERR,X0,X1,Y1,D1,X2,Y2,D2,X,Y,D,XB,YB,DB) INTEGER NOUGHT,NEND,KEND(*),NBOUND,KBOUND(*) INTEGER IY(8),KDIM1,KDIM2,NDIM,MY PARAMETER (MY=35) REAL BOUND(*),ERR,X0,X1,Y1(NDIM),D1(NDIM),X2,Y2(NDIM),D2(NDIM) REAL X,Y(NDIM),D(NDIM),XB,YB(NDIM),DB(NDIM) C C This subroutine determines the point of intersection of the given C curve element with the boundary of the complex block. The curve is C interpolated from the two given points. The subroutine performs the C steps 5.8.3(c), (d) and (e) of the algorithm. C C General meaning of some arguments used: C X1,X2,X,XB... Independent variable along the curve. C Y1,Y2,Y,YB,D1,D2,D,DB... Arrays of the dimension NDIM. C Y1(KDIM1:KDIM2),Y2(KDIM1:KDIM2),Y(KDIM1:KDIM2),YB(KDIM1:KDIM2)... C Coordinates. C D1(1:NDIM),D2(1:NDIM),D(1:NDIM),DB(1:NDIM)... Derivatives of C arrays Y1,Y2,Y,YB with respect to the independent C variable. C C Input: C NOUGHT..Zero if the curve is not situated along the structural C interface, C otherwise the index of the surface on which the curve is C situated. C NEND... Number of end surfaces limiting the computational volume. C Usually NEND=0. C KEND... Contains the indices of end surfaces. C Array of dimension NEND, not used if NEND=0. C NBOUND..Number of isosurfaces of computed quantities, limiting the C computational volume. These isosurfaces will likely be C the boundaries X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX of the C computational volume. C KBOUND..Indices of the quantities corresponding to the C isosurfaces. The computational volume is limited by the C inequalities C Y(IABS(KBOUND(I))).LE.BOUND(I) for KBOUND(I).LT.0, C Y(IABS(KBOUND(I))).GE.BOUND(I) for KBOUND(I).GT.0. C Array of dimension NBOUND, not used if NBOUND=0. C BOUND...Values of the isosurfaces, likely coinciding with C boundaries X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX of the C computational volume. In such a case, KBOUND would take C the values KDIM1,-KDIM1,KDIM1+1,-KDIM1-1,KDIM2,-KDIM2. C Array of dimension NBOUND, not used if NBOUND=0. C KDIM1,KDIM2... KDIM1-th to KDIM2-th elements of arrays Y1,Y2,Y,YB C contain coordinates. KDIM2 is assumed to be KDIM1+2. C NDIM... Dimension of the arrays Y1,Y2,Y,YB,D1,D2,D,DB. It must C not exceed the parameter MY. C IY... Integer array of the dimension at least 8. C IY(4)=ISB1... Index of the simple block containing the point X1. C IY(5)=ICB1... Index of the complex block containing the point X1. C It may (but need not) be supplemented by a sign '+' for P C wave and sign '-' for S wave. C ERR... Maximum error in independent variable for the C determination of the point of intersection. C X0... For X.LE.X0 just the intersection with the boundary of C the computational volume is checked, not with the C structural interfaces. C For X1.LE.X0, the initial point X1 is checked for location C outside the complex block, but very close to its boundary. C In such a case, X0 should be close to X1 (within an C interval of ERR) and may be located inside the complex C block. C X1,Y1,D1... Quantities at the initial point of the curve element. C X2,Y2,D2... Quantities at another point of the curve. The curve C is interpolated using the values and their derivatives at C the points X1 and X2. C X,Y,D...Quantities at the endpoint of the curve element. C XB,YB,DB... Values ignored. C C Output: C NOUGHT,KDIM1,KDIM2,NDIM,ERR,X0,X1,Y1,D1,X2,Y2,D2... Unchanged C input. C IY(1),IY(2),IY(3),IY(5)... Unchanged input. C IY(4)=ISB1... Index of the simple block containing the point X. C Output if the endpoint of the curve element is situated in the complex C block IY(5): C IY(6),IY(7),IY(8)... Unchanged input. C X,Y,D...Unchanged input. C XB,YB,DB... Copy of X,Y,D. C Output if the endpoint of the curve element is situated in another C complex block or outside the computational volume: C IY(6)=ISRF... Index of the surface at which the point of C intersection with the boundary of the complex block is C situated, supplemented by a sign '+' or '-' for the point C situated at the positive or negative side of the surface, C respectively. C IY(7)=ISB2... Index of the simple block touching the complex C block ICB1 from the other side of the surface ISRF at C the point of intersection. C ISB2=0 for a free space on the other side of ISRF. C IY(8)=ICB2... Index of the complex block touching the complex C block ICB1 from the other side of the surface ISRF at C the point of intersection. C ICB2=0 for a free space on the other side of ISRF. C X,Y,D...Values corresponding to the point of intersection of the C curve with the boundary of the complex block or the C computational volume. If possible, this point is situated C inside the given complex block close to its boundary, or C directly on its boundary. C XB,YB,DB... Values corresponding to another approximation of the C point of intersection. This point is situated outside the C the given complex block, close to its boundary or directly C on its boundary. C Note that XB-X should be less than ERR. C C Subroutines and external functions required: EXTERNAL NSRFC,BLOCK,SRFC2,CROSS INTEGER NSRFC C NSRFC,BLOCK... File 'model.for'. C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C CROSS,HIVD2... This file. C C Date: 1999, May 17 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations for local model parameters: FAUX(10), C G(12),GAMMA(18),GSQRD, UP(10),US(10),RO,QP,QS, VP,VS,VD(10),QL: INCLUDE 'auxmod.inc' C auxmod.inc C C....................................................................... C C Other auxiliary storage locations: INTEGER NSRF1,ISRF(2) INTEGER ISRAUX,ISBAUX,ISB1,ISRF2,ISB2,ICB2,K0,K1,K2,K,I REAL XAUX,YAUX(MY),DAUX(MY),X01,Y01(MY),D01(MY) C C ISB1,X01,Y01,D01,VD... Used only to check for the location of the C point X1. C C....................................................................... C C (c) Check for crossing the coordinate boundaries of the C computational volume: DO 31 I=1,NBOUND K=IABS(KBOUND(I)) IF((KBOUND(I).GT.0.AND.Y(K).LT.BOUND(I)).OR. * (KBOUND(I).LT.0.AND.Y(K).GT.BOUND(I))) THEN IY(6)=100+I FAUX(1)=BOUND(I) CALL CROSS(SRFC2,IY(6),K,K,NDIM,ERR,X1,Y1,D1,X2,Y2,D2, * X,Y,D,XB,YB,DB,FAUX) END IF 31 CONTINUE IF(IY(6).GT.100) THEN IY(7)=IY(4) IY(8)=IABS(IY(5)) END IF ISB1=IY(4) C XB=X DO 39 I=1,NDIM YB(I)=Y(I) DB(I)=D(I) 39 CONTINUE C C (d) Check for crossing the boundary of the complex block: C Note: IY(4)=ISB1, IY(5)=ICB1, IY(6)=ISRF. IF(NOUGHT.EQ.0) THEN NSRF1=1 ELSE NSRF1=2 ISRF(2)=NOUGHT END IF IF(X.GT.X0) THEN ISRF(1)=0 CALL BLOCKS(Y(KDIM1),NSRF1,ISRF,IY(4),ISRF2,ISB2,ICB2) IF(ISRF2.NE.0) THEN C Boundary of the simple block is crossed C Note: in this routine, unlike in the paper on C.R.T., the C point of intersection with the boundary of the simple block is C found even if the boundary of the complex block is not C crossed. C (d1) ISRAUX=IY(6) ISBAUX=ISB2 XAUX=X DO 41 I=1,NDIM YAUX(I)=Y(I) DAUX(I)=D(I) 41 CONTINUE C 5.30: CALL SRFC2(IABS(ISRF2),Y(KDIM1),FAUX) C Following loop is included to avoid infinite repeating of the C steps (d2) and (d3) of the algorithm DO 47 K=1,100 C (d2) IY(6)=ISRF2 C (d3) C Check for the location of the point X1 before calling cross IF(X1.LE.X0) THEN C X1 may be located outside the complex block CALL SRFC2(IABS(IY(6)),Y1(KDIM1),VD) IF(VD(1)*FAUX(1).GT.0.) THEN C Points X1 and X are located outside the complex block, C looking for the point X01 between X0 and X, situated C inside the complex block. X01=X0 42 CONTINUE CALL HIVD2(KDIM2-KDIM1+1,X1,Y1(KDIM1),D1(KDIM1),X2, * Y2(KDIM1),D2(KDIM1),X01,Y01(KDIM1),D01(KDIM1)) CALL SRFC2(IABS(IY(6)),Y01(KDIM1),VD) IF(VD(1)*FAUX(1).LE.0.) THEN C Point X01 is likely located inside the complex block ISRF(1)=0 CALL BLOCKS(Y01(KDIM1),NSRF1,ISRF,ISB1,ISRF2,K1,K2) IF(ISRF2.EQ.0) THEN C Point X01 is located inside the simple block ISB1, C point X1 may be replaced by X01. CALL HIVD2(NDIM,X1,Y1,D1,X2,Y2,D2,X01,Y01,D01) CALL CROSS(SRFC2,IABS(IY(6)),KDIM1,KDIM2,NDIM,ERR, * X01,Y01,D01,X2,Y2,D2,X,Y,D,XB,YB,DB,FAUX) GO TO 43 END IF ELSE C Trying a new point X01 IF(X01.EQ.X0) THEN X01=X01+ERR ELSE X01=X01+(X01-X0) END IF IF(X01.LT.X) THEN GO TO 42 END IF END IF END IF END IF CALL CROSS(SRFC2,IABS(IY(6)),KDIM1,KDIM2,NDIM,ERR, * X1,Y1,D1,X2,Y2,D2,X,Y,D,XB,YB,DB,FAUX) 43 CONTINUE C X and XB are the approximations of the point of intersection C with the surface IY(6) ISRF(1)=0 CALL BLOCKS(Y(KDIM1),NSRF1,ISRF,IY(4),ISRF2,ISB2,ICB2) IF(ISRF2.EQ.IY(6).AND.X.NE.X1) THEN C 587 CALL ERROR('587 in CDE: Boundary point out of block') C This error should not appear. Contact the authors. END IF C 5.30: IF(ISRF2.NE.0) THEN CALL SRFC2(IABS(ISRF2),Y(KDIM1),FAUX) END IF IF(ISRF2.NE.0.AND.ISRF2.NE.IY(6).AND. * FAUX(1)*(D(KDIM1)*FAUX(2)+D(KDIM1+1)*FAUX(3) * +D(KDIM2)*FAUX(4)).GT.0.) THEN C (d3-i) C Point X is not situated at the boundary of the simple C block. It is separated from the simple block IY(4) by C the surface ISRF2 situated before (not after) the point X. C Go to (d2) ELSE C X is situated at the boundary of the simple block IY(4) ISRF(1)=0 CALL BLOCKS(YB(KDIM1),NSRF1,ISRF,IY(4),ISRF2,ISB2,ICB2) IF(ISB2.EQ.IY(4)) THEN CALL SRFC2(IABS(IY(6)),YB(KDIM1),FAUX) IF(FAUX(1).NE.0.) THEN C 582 CALL ERROR('582 in CDE: Excluded program branch') C This error should not appear. Contact the authors. END IF C Point XB is situated exactly at the surface IY(6) ISRF(1)=IY(6) CALL BLOCKS(YB(KDIM1),NSRF1,ISRF,IY(4),ISRF2,ISB2,ICB2) END IF C Near the edge of a simple block, two different surfaces C bounding simple block IY(4) may be situated between C points X and XB. In such a case, only one of them C separates simple block IY(4) from ISB2 and IY(6) may C be the second. ISRF(1)=IY(6) CALL BLOCKS(Y(KDIM1),NSRF1,ISRF,IY(4),ISRF2,K1,K2) IF(ISRF2.EQ.0.AND.ISB2.NE.K1) THEN C Surface IY(6) does not form the interface between C simple blocks IY(4) and ISB2: ISRF(1)=IY(6) CALL BLOCKS(YB(KDIM1),NSRF1,ISRF,IY(4),ISRF2,K1,K2) IF(ISRF2.NE.0) THEN C Surface ISRF2 separates the point XB from the simple C block IY(4): ISRF(1)=ISRF2 CALL BLOCKS(Y(KDIM1),NSRF1,ISRF,IY(4),K0,K1,K2) IF(K0.EQ.0.AND.ISB2.EQ.K1) THEN C Surface ISRF2 forms the interface between simple C blocks IY(4) and ISB2: IY(6)=ISRF2 END IF END IF END IF IF(ICB2.EQ.IABS(IY(5))) THEN C (d3-ii) C X,Y is situated at the boundary of the simple block C but not situated at the boundary of the complex block IY(4)=ISB2 X=XAUX DO 45 I=1,NDIM Y(I)=YAUX(I) D(I)=DAUX(I) 45 CONTINUE IF(ISB2.EQ.ISBAUX) THEN C Boundary of the complex block has not been crossed C during the last step of numerical integration XB=X DO 46 I=1,NDIM YB(I)=Y(I) DB(I)=D(I) 46 CONTINUE IY(6)=ISRAUX GO TO 49 END IF ISRF(1)=0 CALL BLOCKS * (YAUX(KDIM1),NSRF1,ISRF,IY(4),ISRF2,ISB2,ICB2) IF(ISRF2.EQ.0) THEN C ISRF2 can be zero only if ISBAUX.EQ.0: IF(ISBAUX.EQ.0) THEN C 5.30: CALL BLOCKS * (Y(KDIM1),NSRF1,ISRF,IY(4),ISRF2,ISB2,ICB2) IF(ISRF2.EQ.0) THEN GO TO 49 END IF ELSE WRITE(*,'(20(A,I3))') ' ISRFC1=',ISRAUX, * ' ISB1=',ISBAUX, * ' ICB1=',IY(5), * ' ISRFC2=',ISRF2, * ' ISB2=',IY(4), * ' ICB2=',ICB2 C 583 CALL ERROR('583 in CDE: Excluded program branch') C This error should not appear. Contact the authors. END IF END IF C 5.30: CALL SRFC2(IABS(ISRF2),YAUX(KDIM1),FAUX) C Go to (d2) ELSE C (d3-iii) C X is situated at the boundary of the simple block and C X is situated at the boundary of the complex block GO TO 48 END IF END IF 47 CONTINUE C 581 CALL ERROR('581 in CDE: Too many fictitious interfaces') C More than 100 fictitious interfaces crossed during one C step of the numerical integration. C This error should not appear. Contact the authors. 48 CONTINUE IY(7)=ISB2 IY(8)=ICB2 END IF 49 CONTINUE END IF C C (e) Check for crossing the end surfaces DO 51 I=1,NEND IF(IABS(KEND(I)).GT.NSRFC()) THEN CALL SRFC2(IABS(KEND(I)),Y(KDIM1),FAUX) IF(FAUX(1)*FLOAT(KEND(I)).LE.0.) THEN IY(6)=IABS(KEND(I)) CALL CROSS(SRFC2,IY(6),KDIM1,KDIM2,NDIM,ERR, * X1,Y1,D1,X2,Y2,D2,X,Y,D,XB,YB,DB,FAUX) END IF END IF 51 CONTINUE C RETURN END C C======================================================================= C C C SUBROUTINE CROSS(SRFC2,ISRF,KDIM1,KDIM2,NDIM, * ERR,X1,Y1,D1,X2,Y2,D2,XA,YA,DA,XB,YB,DB,F) EXTERNAL SRFC2 INTEGER ISRF,KDIM1,KDIM2,NDIM REAL ERR,X1,Y1(NDIM),D1(NDIM),X2,Y2(NDIM),D2(NDIM) REAL XA,YA(NDIM),DA(NDIM),XB,YB(NDIM),DB(NDIM),F(10) C C This subroutine finds the point of intersection of a curve with C a surface (see C.R.T.5.8.4b). The curve is parametrized by an C independent variable X and evaluated by the Hermite interpolation from C the two given points. The surface is specified in an implicit way by C subroutine SRFC2 which is described elsewhere, or may coincide with an C isosurface of a computed quantity (e.g. with a coordinate plane). C C Input: C SRFC2...Name of the external procedure evaluating the function C describing the surface ISRF, for ISRF.LE.100. C ISRF... Index of the surface. C For ISRF.LE.100: C The surface coincides with the zero isosurface of the C function no. ISRF evaluated by the subroutine SRFC2. C For ISRF.GT.100: C The surface coincides with an isosurface Y(KDIM1)=F(1). C KDIM1,KDIM2... Indices of quantities on which the function C describing the surface is dependent: C For ISRF.LE.100: C KDIM1-th to KDIM2-th elements of arrays Y1, Y2, YA, and C YB contain coordinates. KDIM2 is assumed to be KDIM1+1 C (2 coordinates) or KDIM1+2 (3 coordinates). C The function describing the surface ISRF is determined C by the subroutine SRFC2. C For ISRF.GT.100: C The surface coincides with an isosurface Y(KDIM1)=F(1). C KDIM2 is assumed to equal KDIM1. C When searching for the point of intersection, only C quantities Y(KDIM1:KDIM2) and their derivatives are C interpolated along the curve. C NDIM... Dimension of arrays Y1,D1,Y2,D2,YA,DA,YB,DB. C At the point of intersection, quantities Y(1:NDIM) and C their derivatives are interpolated. C ERR... Maximum error in independent variable for the C determination of the point of intersection. C X1... Independent variable corresponding to the first point C given for the interpolation of the curve. C Y1... Array containing dependent variables at point X1. C Y1(KDIM1) to Y1(KDIM2) must contain the coordinates of C point X1. C D1... Array containing the derivatives of the dependent C variables at point X1. C X2... Independent variable corresponding to the second point C given for the interpolation of the curve. C Y2... Array containing dependent variables at point X2. C Y2(KDIM1) to Y2(KDIM2) must contain the coordinates of C point X2. C D2... Array containing the derivatives of the dependent C variables at point X2. C XA... Independent variable corresponding to the point of the C curve at which the function specifying the surface has the C opposite sign than at X1. Then the point of intersection C is being found between the points X1 and XA. The found C approximations XA and XB of the point of intersection are C situated close to the surface, XA at the same side as the C given point X1, XB at the oposite side than the given C point X1. If, accidentally, the function has the same C sign at the points X1 and XA, the value at X1 is assumed C to equal zero. Then XA=X1 and XB=X1 on output. C YA... Array of the dimension at least NDIM. YA(KDIM1) to C YA(KDIM2) must contain the coordinates of the point. C Other storage locations may be undefined. C DA... Array of the dimension at least NDIM, containing the C derivatives of the dependent variables at point X. C DA(KDIM1) to DA(KDIM2) must contain the derivatives of C coordinates with respect to X, at the point XA. Other C storage locations may be undefined. C YB... Array of the dimension at least NDIM. C DB... Array of the dimension at least NDIM. C F... For ISRF.LE.100: C Array containing the value, and at least first C derivatives of the function ISRF specifying the surface, C at point XA. C For ISRF.GT.100: C The surface coincides with an isosurface Y(KDIM1)=F(1). C F(2) to F(10) need not be defined. C ISRF, KDIM1, KDIM2, NDIM, ERR, X1, Y1, D1, X2, Y2, D2 are unaltered. C C Output: C XA... Independent variable corresponding to the approximation of C the point of intersection, situated close to the surface C at the same side as the given point X1. XA=X1 if the C function had at point X1 the same sign as F(1) on input. C YA... Array containing dependent variables at the point XA. C DA... Array containing the derivatives of the dependent C variables at the point XA. C XB... Independent variable corresponding to the approximation of C the point of intersection, situated close to the surface C at the oposite side than the given point X1. XB=X1 if the C function had at point X1 the same sign as F(1) on input. C YB... Array containing dependent variables at the point XB. C DB... Array containing the derivatives of the dependent C variables at the point XB. C F... Undefined. C C Subroutines and external functions required: EXTERNAL HIVD2 C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for') - dummy argument. C HIVD2... This file. C C Date: 1996, July 10 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I,ITER REAL FAOLD,X,FX,DFX,FB,DFB,FA,DFA,XC,XCB *old REAL ,XCA *!!! REAL XD,XD2,XE,AUX0,AUX1,AUX2,AUX3 *out real xam(50),fam(50),dfam(50),xbm(50),fbm(50),dfbm(50) *out integer icross,jcross,mcross *out data icross,jcross,mcross/0,0,0/ C C....................................................................... C C Initial values: IF(ISRF.LE.100) THEN FA=F(1) DFA=F(2)*DA(KDIM1) DO 1 I=1,KDIM2-KDIM1 DFA=DFA+F(2+I)*DA(KDIM1+I) 1 CONTINUE ELSE FA=YA(KDIM1)-F(1) DFA=DA(KDIM1) END IF FAOLD=FA XB=X1 X =X1 DO 2 I=KDIM1,KDIM2 YB(I)=Y1(I) DB(I)=D1(I) 2 CONTINUE C In the beginning, both points XB and X are identical with point X1 C C Check for zero intervals: IF(XA.EQ.X1) THEN DO 3 I=1,NDIM YA(I)=Y1(I) DA(I)=D1(I) YB(I)=Y1(I) DB(I)=D1(I) 3 CONTINUE RETURN END IF IF(X2.EQ.X1) THEN C 585 CALL ERROR('585 in CROSS: Zero-length interval') C Two points X1 and X2 used for interpolation of the given C line (e.g. the velocity isoline, or the ray), when C searching for its intersection with the interface, are C identical and no interpolation is possible. Likely a bug C in the procedure calling this subroutine. END IF C C Iterations: DO 9 ITER=1,50 C C Functional value and derivative at X: IF(ISRF.LE.100) THEN CALL SRFC2(ISRF,YB(KDIM1),F) FX=F(1) DFX=F(2)*DB(KDIM1) DO 5 I=1,KDIM2-KDIM1 DFX=DFX+F(2+I)*DB(KDIM1+I) 5 CONTINUE ELSE FX=YB(KDIM1)-F(1) DFX=DB(KDIM1) END IF C C Selection of points: IF(FX.EQ.0.) THEN XA=X FA=FX ELSE IF(FA*FX.GE.0.) THEN IF(ITER.EQ.1) THEN C Input points X1 and XA are situated at the same side IF(FA.EQ.0.) THEN X=XA FX=FA ELSE XA=X FA=FX END IF ELSE C Here FA, FX and FB should be non-zero due to previous checks XA=XB FA=FB DFA=DFB END IF END IF XB=X FB=FX DFB=DFX C *out xam(iter)=xa *out fam(iter)=fa *out dfam(iter)=dfa *out xbm(iter)=xb *out fbm(iter)=fb *out dfbm(iter)=dfb c C New point or end of iterations: IF(ABS(XB-XA).LE.ERR) THEN C Point of intersection is found within the specified error err C *** end of iterations *** IF(FB*FAOLD.LT.0.) THEN C Point XA is situated at the other side of the surface than C the point X1 - changing XA and XB X =XA XA=XB XB=X END IF IF((XB-XA)*(XB-X1).LT.0.) THEN C Point XB is closer to X1 than point XA IF(FA*FB.LT.0.) THEN C Points XA and XB cannot be changed C 586 CALL ERROR('586 in CROSS: Reverse order of points') C A pair of close points XA and XB situated at different C sides of the surface has been found, but point XA situated C at the same side as point X1 is far from X1 than point XB. C This error should not appear. Contact the authors. ELSE C Points XA and XB are situated at the same side of the C surface (and, hopefully, FA and FB should be zero) C - changing XA and XB X =XA XA=XB XB=X END IF END IF CALL HIVD2(NDIM,X1,Y1,D1,X2,Y2,D2,XA,YA,DA) CALL HIVD2(NDIM,X1,Y1,D1,X2,Y2,D2,XB,YB,DB) *out if(icross.eq.0) then *out open(57,file='cross.out') *out end if *out icross=icross+1 *out jcross=jcross+iter-1 *out mcross=max0(mcross,iter-1) *out if(mod(icross,100).eq.0) then *out write(57,*) icross,jcross,mcross,float(jcross)/float(icross) *out end if *out if(iter.gt.20) then *out open(58,file='error.out') *out do 7 I=1,iter *out write(58,*) xam(i),xbm(i),fam(i),fbm(i),dfam(i),dfbm(i) *out7 continue *out endfile (58) *out backspace(58) *out pause 'Error new in CROSS: More than 20 iterations' *out end if RETURN END IF C cccc (a) Odstranit *old cccc (b) Odstranit *old, odstranit *??? cccc (c) Odstranit *old, odstranit *???, odstranit *new (nedulezite) cccc (d) Vratit *old, vratit *???, vratit *new cccc (e) Odstranit *!!! cccc (f) Odstranit *!!!, odstranit *old cccc C New approximation: IF(MOD(ITER,2).EQ.1) THEN C Regula falsi: X=(FA*XB-FB*XA)/(FA-FB) C!!! CHECKING THE ACCURACY OF THE REGULA FALSI METHOD: *!!! IF(ITER.EQ.1) THEN C!!! COEFFICIENTS OF THE CUBIC TAYLOR EXPANSION AT XC=(XA+XB)/2.: *!!! XD=XB-XA *!!! XD2=XD*XD/2. *!!! AUX3=(DFB+DFA)/2. *!!! AUX2=(DFB-DFA)/XD *!!! AUX1=(FB-FA)/XD *!!! AUX0=(FB+FA)/2.-AUX2*XD2 *!!! AUX1=1.5*AUX1-0.5*AUX3 *!!! AUX3=(AUX3-AUX1)/XD2 C!!! COEFFICIENTS OF THE QUADRATIC TAYLOR EXPANSION AT X: *!!! XD=X-XC *!!! XD=X-XC *!!! XD2=XD*XD/2. *!!! XE=SIGN(1.,AUX1) *!!! AUX0=AUX0+AUX1*XD+AUX2*XD2+AUX3*XD*XD2/3. *!!! AUX1=AUX1+AUX2*XD+AUX3*XD2 *!!! IF(ABS(AUX0).GT.0.5*ERR*ABS(AUX1)) THEN C!!! THE ACCURACY SHOULD BE IMPROVED: *!!! AUX2=AUX2+AUX3*XD *!!! AUX3=AUX1**2-2.*AUX0*AUX2 C!!! HERE 2**(24/2)=4096 ASSUMES 24 BIT FLOATING-POINT ACCURACY *!!! IF(4096.*ABS(AUX0*AUX2).GT.AUX1**2.AND.AUX3.GE.0.) THEN *!!! XE=X+(XE*SQRT(AUX3)-AUX1)/AUX2 *!!! ELSE *!!! XE=X-AUX0/AUX1 *!!! END IF *!!! IF((XE-XA)*(XE-XB).LE.0.) THEN *!!! X=XE *!!! END IF *!!! END IF *!!! END IF ELSE C Modified Newton-Raphson: XC=(XA+XB)/2. *old XCA=XA-FA/DFA+SIGN(ERR/50.,XA-XB) XCB=XB-FB/DFB+SIGN(ERR/50.,XA-XB) *old IF((XCA-XC)*(XCA-XB).LT.0.) THEN *old IF((XCB-XC)*(XCB-XB).LT.0.) THEN *old IF(ABS(XCA-XB).LT.ABS(XCB-XB)) THEN *old X=XCA *old ELSE *old X=XCB *old END IF *old ELSE *old X=XCA *old END IF *old ELSE IF((XCB-XC)*(XCB-XB).LT.0.) THEN X=XCB ELSE X=XC *??? IF(ABS(XCB-XB).LT.SQRT(ABS(XC-XB)*ERR)) THEN C Attempt to halve the number of iterations *??? X=XB+SIGN(SQRT(ABS(XC-XB)*ERR),XA-XB) *new IF((X-XC)*(X-XB).GE.0.) THEN *new X=XC *new pause 'New warning in CROSS' *new END IF *??? END IF END IF *old END IF END IF C C Interpolation of the ray: CALL HIVD2(KDIM2-KDIM1+1,X1,Y1(KDIM1),D1(KDIM1), * X2,Y2(KDIM1),D2(KDIM1),X,YB(KDIM1),DB(KDIM1)) C 9 CONTINUE C End of loop for iterations *out open(58,file='error.out') *out do 8 iter=1,50 *out write(58,*) xam(iter),xbm(iter),fam(iter),fbm(iter), *out * dfam(iter),dfbm(iter) *out8 continue C 584 CALL ERROR('584 in CROSS: Too many iterations') C More than 50 iterations when determining the point of C intersection of the ray with a surface. This may be C caused by too small upper error bound UEB in the input C data 'dcrt.dat' - less than rounding errors. Usually, C this error should not appear. Contact the authors. END C C======================================================================= C C C SUBROUTINE HIVD2(NDIM,X1,Y1,D1,X2,Y2,D2,X,Y,D) INTEGER NDIM REAL X1,Y1(NDIM),D1(NDIM),X2,Y2(NDIM),D2(NDIM) REAL X,Y(NDIM),D(NDIM) C C This subroutine performs Hermite interpolation of a vector and its C derivatives using functional values and derivatives at 2 given points. C C Input: C NDIM... Dimension of arrays Y1,D1,Y2,D2,Y,D (the number of C independent variables). C X1... Independent variable corresponding to the first given C point. C Y1... Array containing functional values at the first given C point. C D1... Array containing the derivatives at the first given point. C X2... Independent variable corresponding to the second given C point. C Y2... Array containing functional values at the second given C point. C D2... Array containing the derivatives at the second given point C X... Independent variable of the point at which the C interpolated vector is to be evaluated. C None of the input parameters are altered. C C Output: C Y... Array containing interpolated functional values at X. C D... Array containing the derivatives of the interpolated C functional values at X. C C No subroutines and external functions required. C C Date: 1989, October 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL A,B,A1,A2,B1,B2,DA1,DB1,DB2 C C Substitutions: A=(X-X2)/(X1-X2) B=(A-1.)*A C C Basic functions: A1=(A-B-B)*A A2=1.-A1 B1=B*(X-X2) B2=B*(X-X1) C Derivatives of basic functions: DA1=6.*B/(X2-X1) DB1=3.*B+A DB2=3.*B+1.-A C C Interpolation: DO 1 I=1,NDIM Y(I)=A1*Y1(I)+A2*Y2(I)+B1*D1(I)+B2*D2(I) D(I)=DA1*(Y1(I)-Y2(I))+DB1*D1(I)+DB2*D2(I) 1 CONTINUE C RETURN END C C======================================================================= C C C SUBROUTINE SMVPRD(G,A1,A2,A3,B1,B2,B3) REAL G(6),A1,A2,A3,B1,B2,B3 C C This subroutine is designed to evaluate symmetric matrix by vector C product. It may be, e.g., called after the invocation of the METRIC C subroutine to transform the covariant vectors to the contravariant C ones and vice versa. C C Input: C G... Array containing components G11, G12, G22, G13, G23, G33 C of the 3*3 symmetric matrix. C A1,A2,A3... Components of the 3-vector. C C Output: C B1,B2,B3... Components of vector B=G*A. C C No subroutines and external functions required. C C Date: 1989, September 5 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C B1=G(1)*A1+G(2)*A2+G(4)*A3 B2=G(2)*A1+G(3)*A2+G(5)*A3 B3=G(4)*A1+G(5)*A2+G(6)*A3 RETURN END C C======================================================================= Cmetric.for 0100666 0000765 0000765 00000025074 07123332210 012425 0 ustar bulant bulant C
C Subroutine file 'metric.for' to define the coordinate system C C Date: 2000, June 19 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C METR1...Subroutine designed to store the data into the common C block /METRC/. C METR1 C KOOR... Integer function returning the type of the coordinate C system. C KOOR C METRIC..Subroutine designed to evaluate the metric tensor and C Christoffel symbols at a given point. C METRIC C CARTES..Subroutine designed to transform the model coordinates to C Cartesian coordinates and vice versa. The indexing of C coordinate systems should correspond to the subroutine C METRIC. C CARTES C C....................................................................... C C Storage in the memory: C The data describing the coordinate system are stored in the common C block /METRC/ defined in the include file 'metric.inc'. C metric.inc C C======================================================================= C C C SUBROUTINE METR1(KOOR) INTEGER KOOR C C Subroutine METR1 is designed to store the data specifying the C coordinate system into the common block /METRC/. C C Input: C KOOR... Specifies the type of the right-handed coordinate system. C The input parameter is not altered. C C No output. C C Common block /METRC/: INCLUDE 'metric.inc' C metric.inc C All the storage locations of the common block are defined in this C subroutine. C C No subroutines and external functions required. C C Date: 1993, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C No auxiliary storage locations. C KOORS=KOOR RETURN END C C======================================================================= C C C INTEGER FUNCTION KOOR() C C Integer function KOOR is designed to return the type of the coordinate C system. C C No input. C C Output: C KOOR... Specifies the type of the right-handed coordinate system: C KOOR.LE.0: Cartesian coordinates. C KOOR.EQ.1: Polar spherical coordinates (X1,X2,X3)= C (COLATITUDE,LONGITUDE,RADIUS). C KOOR.GE.2: Geographic spherical coordinates (X1,X2,X3)= C (longitude,latitude,radius). C C Common block /METRC/: INCLUDE 'metric.inc' C metric.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1989, December 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C No auxiliary storage locations. C KOOR=KOORS RETURN END C C======================================================================= C C C SUBROUTINE METRIC(COOR,GSQRD,G,GAMMA) REAL COOR(3),GSQRD,G(12),GAMMA(18) C C This subroutine evaluates the metric tensor and Christoffel C symbols at a given point. C C Input: C COOR... Array containing coordinates X1, X2, X3 of the given point C None of the input parameters are altered. C C Output: C GSQRD...Square root of the determinant of the covariant metric C tensor. C G... Array containing covariant components G11, G12, G22, G13, C G23, G33, and contravariant components G11, G12, G22, G13, C G23, G33 of the metric tensor at the given point. C GAMMA...Array containing Christoffel symbols GAMMA111, GAMMA121, C GAMMA221, GAMMA131, GAMMA231, GAMMA331, GAMMA112, C GAMMA122, GAMMA222, GAMMA132, GAMMA232, GAMMA332, C GAMMA113, GAMMA123, GAMMA223, GAMMA133, GAMMA233, C GAMMA333, where the first two indices are subscripts and C the third index is a superscript. C C Common block /METRC/: INCLUDE 'metric.inc' C metric.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 2000, June 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C INTEGER I REAL SMALL,C,S,R PARAMETER (SMALL=1.E-12) C C I... Auxiliary loop variable. C SMALL...The lower limit for the distance from the singularities of C the coordinate system measured in the coordinate units. C C,S,R...Auxiliary storage locations. C C....................................................................... C DO 1 I=1,12 G(I)=0. 1 CONTINUE DO 2 I=1,18 GAMMA(I)=0. 2 CONTINUE C IF(KOORS.LE.0) THEN GSQRD=1. G(1) =1. G(3) =1. G(6) =1. G(7) =1. G(9) =1. G(12)=1. ELSE IF(KOORS.EQ.1) THEN C=COS(COOR(1)) S=SIN(COOR(1)) R=COOR(3) IF(S.EQ.0.) S=SMALL IF(R.EQ.0.) R=SMALL GSQRD=R*R*ABS(S) G(1) =R*R G(3) =(R*S)**2 G(6) =1. G(7) =1./G(1) G(9) =1./G(3) G(12)=1. GAMMA(3) =-S*C GAMMA(4) =1./R GAMMA(8) =C/S GAMMA(11)=1./R GAMMA(13)=-R GAMMA(15)=-R*S*S ELSE C=COS(COOR(2)) S=SIN(COOR(2)) R=COOR(3) IF(C.EQ.0.) C=SMALL IF(R.EQ.0.) R=SMALL GSQRD=R*R*ABS(C) G(1)=(R*C)**2 G(3)=R*R G(6)=1. G(7)=1./G(1) G(9)=1./G(3) G(12)=1. GAMMA(2)=-S/C GAMMA(4)=1./R GAMMA(7)=S*C GAMMA(11)=1./R GAMMA(13)=-R*C*C GAMMA(15)=-R END IF RETURN END C C======================================================================= C C C SUBROUTINE CARTES(COOR,TO,CART,PDER) LOGICAL TO REAL COOR(3),CART(3),PDER(9) C C This subroutine transforms the model coordinates to Cartesian C coordinates and vice versa. This subroutine has to correspond to the C subroutine METRIC. C C Arguments: C COOR... Array containing the model coordinates X1,X2,X3 of the C given point. C TO... .TRUE. To transform the model coordinates to the Cartesian C coordinates. C Input: COOR, C Output: CART,PDER. C .FALSE. To transform the Cartesian coordinates to the C model coordinates. C Input: CART, C Output: COOR,PDER. C CART... Array containing the Cartesian coordinates C1, C2, C3 of C the given point. C PDER... Partial derivatives of the output coordinates with respect C to the input coordinates. I.e. the transformation matrix C of contravariant vectors, corresponding to the coordinate C transformation. I.e. the transposed transformation matrix C of covariant vectors, corresponding to the inverse C transformation. C C Subroutines and external functions required: EXTERNAL KOOR INTEGER KOOR C KOOR... This file. C C Date: 1996, September 30 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL C,S,R C C....................................................................... C IF(KOOR().LE.0) THEN C Cartesian coordinates: IF(TO) THEN CART(1)=COOR(1) CART(2)=COOR(2) CART(3)=COOR(3) ELSE COOR(1)=CART(1) COOR(2)=CART(2) COOR(3)=CART(3) END IF DO 11 I=2,8 PDER(I)=0. 11 CONTINUE DO 12 I=1,9,4 PDER(I)=1. 12 CONTINUE ELSE IF(KOOR().EQ.1) THEN C Polar spherical coordinates: IF(TO) THEN R=COOR(3) S=R*SIN(COOR(1)) CART(1)=S*COS(COOR(2)) CART(2)=S*SIN(COOR(2)) CART(3)=R*COS(COOR(1)) PDER(1)= CART(1)*CART(3)/S PDER(2)= CART(2)*CART(3)/S PDER(3)=-S PDER(4)=-CART(2) PDER(5)= CART(1) PDER(6)= 0. PDER(7)= CART(1)/R PDER(8)= CART(2)/R PDER(9)= CART(3)/R ELSE S=CART(1)**2+CART(2)**2 R=SQRT(S+CART(3)**2) S=SQRT(S) IF(R.NE.0.) THEN COOR(1)=ATAN2(S,CART(3)) ELSE COOR(1)=0. END IF IF(S.NE.0.) THEN COOR(2)=ATAN2(CART(2),CART(1)) ELSE COOR(2)=0. END IF COOR(3)=R PDER(1)= CART(1)*CART(3)/S/R PDER(2)=-CART(2)/S PDER(3)= CART(1)/R PDER(4)= CART(2)*CART(3)/S/R PDER(5)= CART(1)/S PDER(6)= CART(2)/R PDER(7)=-S/R PDER(8)= 0. PDER(9)= CART(3)/R END IF ELSE C Geographic spherical coordinates: IF(TO) THEN R=COOR(3) C=R*COS(COOR(2)) CART(1)=C*COS(COOR(1)) CART(2)=C*SIN(COOR(1)) CART(3)=R*SIN(COOR(2)) PDER(1)=-CART(2) PDER(2)= CART(1) PDER(3)= 0. PDER(4)=-CART(1)*CART(3)/C PDER(5)=-CART(2)*CART(3)/C PDER(6)= C PDER(7)= CART(1)/R PDER(8)= CART(2)/R PDER(9)= CART(3)/R ELSE C=CART(1)**2+CART(2)**2 R=SQRT(C+CART(3)**2) C=SQRT(C) IF(R.NE.0.) THEN COOR(2)= ATAN2(CART(3),C) PDER(3)= CART(1)/R PDER(6)= CART(2)/R PDER(8)= C/R PDER(9)= CART(3)/R ELSE COOR(2)= 0. PDER(3)= 1. PDER(6)= 1. PDER(8)= 0. PDER(9)= 1. END IF IF(C.NE.0.) THEN COOR(1)= ATAN2(CART(2),CART(1)) PDER(1)=-CART(2)/C PDER(2)=-CART(1)*CART(3)/C/R PDER(4)= CART(1)/C PDER(5)=-CART(2)*CART(3)/C/R ELSE COOR(1)= 0. PDER(1)= 0. PDER(2)=-1. PDER(4)= 0. PDER(5)=-1. END IF COOR(3)= R PDER(7)= 0. END IF END IF RETURN END C C======================================================================= Cmetric.inc 0100666 0000765 0000765 00000001664 06355637666 012444 0 ustar bulant bulant C
C INCLUDE 'metric.inc' C ------------------------------------------------------------------ INTEGER KOORS COMMON/METRC/KOORS SAVE /METRC/ C ------------------------------------------------------------------ C KOORS...Specifies the type of the right-handed coordinate system: C KOORS.LE.0: Cartesian coordinates. C KOORS.EQ.1: Polar spherical coordinates (X1,X2,X3)= C (colatitude,longitude,radius). C KOORS.GE.2: Geographic spherical coordinates (X1,X2,X3)= C (longitude,latitude,radius). C C Common block /METRC/ is included in FORTRAN 77 source code files C 'metric.for'. C C Date: 1996, July 8 C Coded by Ludek Klimes C C======================================================================= Cmodchk.for 0100666 0000765 0000765 00000061770 07263003610 012416 0 ustar bulant bulant C
C Program MODCHK to perform the consistency check of the data describing C the structure of the model. C C Version: 5.50 C Date: 2001, April 5 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 Logical test for possible cavities in the model: C C The MODEL package does not require the free-space block to be C explicitly specified. All simple blocks, not defined in the data C file describing the model, are deemed to be free-space blocks. C In such a case, it is hard to check for the possible cavities C in the model. Although the 'modchk' program reports all simple C blocks that could, in principle, form such cavities, most of the C reported simple blocks are parts of the desired free space and C often mutually overlap. The number of reported undefined simple C blocks is thus often too large to be comfortably checked by a C user. C C It is thus recommended to specify free-space simple blocks in C addition to the material simple blocks. It may be done directly C in the data file specifying the model. All given simple blocks C which do not form material complex blocks are deemed to be C free-space simple blocks. Since the free-space simple blocks need C not be explicitly specified in the model data, they may also be C specified in a separate file submitted to the 'modchk' program. C The table of simple blocks in the separate file is just a C continuation of the corresponding table in the model data file. C Then the list of undefined free-space simple blocks reported by C the 'modchk' program should be much more useful. C C Although the undefined free-space blocks need not necessarily C physically exist and form cavities in the particular model, they C should be removed. They may often be unified with a neighbouring C simple block from which they are separated by an interface. C Especially if a user knows that an undefined simple block does C not physically exist, there is often no reason to separate it C from neighbouring defined simple blocks. If an undefined simple C block is allowed to form free space, the list of free-space blocks C should be updated. C C It is recommended to fix all undefined free-space simple blocks C before performing detailed numerical test for overlapping simple C and complex blocks in the model. C C Example: Assume three mutually intersecting interfaces 1, 2, 3, C limiting four simple blocks in the following way: C +3- C / C / C / | C / | C (+1,+3) / | C / | C / | C + / (+1,-2,-3)| C 1-----------------|(+2,-3) C - (-1,-2) | C | C -2+ C Then simple block (-1,+2,+3) is an undefined free-space simple C block and is reported by program 'modchk'. Although simple block C (-1,+2,+3) probably does not exist, it is recommended to make it C defined. The best way would be to unify it with an existing C simple block. Unfortunately, block (-1,+2,+3) cannot by simply C unified with any of the above simple blocks (+1,+3), (-1,-2), C (+2,-3), (+1,-2,-3). There are still at least two possibilities C how to fix this problem: C (a) C A safer but slower way is to define also simple block (-1,+2,+3) C and to attach it to a material of free-space complex block. C (b) C If we are sure that simple block (-1,+2,+3) does not exist and C thus cannot form an undesired cavity in the model, we may leave it C undefined free-space simple block, and run the 'modchk' program C with parameter LFREE=0 and dense test grid. C C Numerical test for overlapping simple or complex blocks in the model: C C The model is covered by a regular rectangular grid of points. C The position of each gridpoint with respect to all simple blocks C is then determined. Normally, each gridpoint situated inside C two or more simple blocks is reported. Here the word 'inside', C naturally, does not include the boundary of a simple block. C C Although overlapping simple blocks in the model are allowed if C they form the same complex blocks, the are not recommended. C If the overlapping simple blocks are present in the model, the C test for overlapping simple blocks may be disabled. In such a C case, only overlapping complex blocks are reported. C C It is reasonable to start the numerical test for overlapping C blocks with a small numbers of gridpoints (e.g., 10*10*10), and C increase the number of gridpoints if the model passes successfully C the first test, and so on. The number of gridpoints for the final C test is limited especially by the computational time. 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 file with model and of the output file: C MODEL='string' ... Name of the input data file specifying C the model to be checked for consistency. C Default: MODEL='model.dat' C Description of MODEL C Example of MODEL C MODCHK='string' ... Name of the input data file containing C the additional free-space blocks. C Description of input file MODCHK C Default: MODCHK=' ' (no additional free-space blocks) C MODLOG='string' ... Name of the output data file with the C report on the consistency check. C Default: MODLOG='modchk.out' C Data for the model consistency check: C N1=integer, N2=integer, N3=integer ... Specification of the C regular rectangular grid of points for the numerical test C for overlapping simple or complex blocks in the model. C The model volume is divided into N1*N2*N3 rectangular C cells. The (N1+1)*(N2+1)*(N3+1) gridpoints are the corner C points of the cells. C If one of N1,N2,N3 is zero, the model is assumed 2-D. C The corresponding 2-D test grid then passes through the C centre of the 3-D model volume. C If all N1,N2,N3 are zero, the numerical test for C overlapping simple or complex blocks is not performed. C Defaults: N1=0, N2=0, N3=0 C LOVER=integer ... Value indicating whether the overlapping simple C blocks are allowed in the model. C LOVER=0: Overlapping simple blocks are reported. C LOVER=1: Overlapping complex blocks are reported. C Default: LOVER=0 C LFREE=integer ... Value indicating whether undefined free-space C simple blocks are to be reported together with overlapping C blocks. C LFREE=0: Undefined free-space simple blocks are not C reported. C LFREE=1: Undefined free-space simple blocks are reported. C Default: LFREE=0 C C C Input file 'MODCHK' specifying additional free-space simple blocks: C (1) NSBADD C Number of additional free-space simple blocks defined within this C data file. See also description of data (5) in 'model.for'. C (2) NSBADD input operations (READ statements): C For each simple block with index ISB, the indices of the surfaces C forming the set F(+) and the indices of the surfaces forming the C set F(-). The indices of surfaces from F(+) must be positive, the C indices of surfaces from F(-) must be indicated by negative signs. C The indices may be specified in an arbitrary order and must be C terminated by a slash. These data lines form the continuation of C of data (6) described in 'model.for'. C C======================================================================= C C Common blocks /MODELT/ and /MODELC/: INCLUDE 'model.inc' C model.inc C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C Allocation of the working array: INTEGER MUB PARAMETER (MUB=MRAM) INTEGER KUB(MUB) EQUIVALENCE (KUB,RAM) C C----------------------------------------------------------------------- C CHARACTER*80 FILSEP INTEGER LU0 PARAMETER (LU0=1) C Input data: CHARACTER*80 FMODEL,FCHK,FOUT INTEGER ILOVER,ILFREE LOGICAL LOVER,LFREE INTEGER LU1,N1,N2,N3 PARAMETER (LU1=1) C C Temporary storage locations: INTEGER NSBOLD,I,J,K,L C C Logical test for undefined free-space simple blocks: INTEGER NUB,KUBNUB,NUNDEF,ISRF,ISB INTEGER MININT,MINSUB,MINKUB,NUMINT,NUMSUB C NUB... Starting index of the last candidate for undefined block C in array KUB. Each candidate occupies NSB+1 locations. C KUB(NUB)... Number of interfaces limiting the last candidate. C KUB(NUB+1:NUB+KUB(NUB))... Indices of interfaces limiting the last C candidate, including signs. C KUB(NUB+KUB(NUB)+1,NUB+NSB)... Indices of simple blocks with which C complements the candidate should be intersected. C Similarly for preceding candidates, if any. C NUNDEF... Number of undefined free-space simple blocks. C C Numerical test for overlapping blocks: INTEGER I1,I2,I3,I123,N123,NB,IB(100) REAL COOR(3) C C----------------------------------------------------------------------- C C Reading name of SEP file with input data: WRITE(*,'(A)') '+MODCHK: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP WRITE(*,'(A)') '+MODCHK: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU0,FILSEP) ELSE C MODCHK-05 CALL ERROR('MODCHK-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 C Reading input parameters from the SEP file: CALL RSEP3T('MODEL',FMODEL,'model.dat') CALL RSEP3T('MODCHK',FCHK,' ') CALL RSEP3T('MODLOG',FOUT,'modchk.out') CALL RSEP3I('N1',N1,0) CALL RSEP3I('N2',N2,0) CALL RSEP3I('N3',N3,0) CALL RSEP3I('LOVER',ILOVER,0) CALL RSEP3I('LFREE',ILFREE,0) IF (ILOVER.EQ.0) THEN LOVER=.FALSE. ELSE LOVER=.TRUE. ENDIF IF (ILFREE.EQ.0) THEN LFREE=.FALSE. ELSE LFREE=.TRUE. ENDIF C C Reading data for model: OPEN(LU1,FILE=FMODEL,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) C C Reading additional free-space simple blocks: NSBOLD=NSB IF(FCHK.NE.' ') THEN OPEN(LU1,FILE=FCHK,STATUS='OLD') C Number of additional simple blocks READ(LU1,*) K IF(KSB(NSB)+K.GT.MSB) THEN C MODCHK-01 CALL ERROR('MODCHK-01: Insufficient memory in /MODELC/') END IF DO 10 J=KSB(NSB),NSB+1,-1 KSB(J+K)=KSB(J) 10 CONTINUE DO 11 J=NSB,1,-1 KSB(J)=KSB(J)+K 11 CONTINUE NSB=NSB+K C Reading indices of surfaces bounding additional simple blocks: L=KSB(NSBOLD)+1 DO 14 J=NSBOLD+1,NSB READ(LU1,*) (KSB(I),I=L,MSB) DO 12 I=L,MSB IF(IABS(KSB(I)).GT.NSRFCS) THEN C MODCHK-02 CALL ERROR('MODCHK-02: Block bounded by wrong interface') ELSE IF(KSB(I).EQ.0) THEN KSB(J)=I-1 L=I GO TO 13 END IF 12 CONTINUE C MODCHK-03 CALL ERROR('MODCHK-03: Insufficient memory in /MODELC/') 13 CONTINUE 14 CONTINUE END IF CLOSE(LU1) C C Opening output report file: OPEN(LU1,FILE=FOUT) WRITE(LU1,'(A)') 'Report on the consistency check of the model' WRITE(LU1,'(A)') WRITE(LU1,'(I3,A)') NSBOLD, * ' simple blocks defined in model data file' WRITE(LU1,'(A)') FMODEL IF(FCHK.EQ.' ') THEN WRITE(LU1,'(2A)') 'None additional free-space simple block', * ' defined for the consistency check.' ELSE WRITE(LU1,'(I3,A)') NSB-NSBOLD, * ' additional free-space simple blocks defined in file' WRITE(LU1,'(A)') FCHK END IF WRITE(LU1,'(A)') C C....................................................................... C C Defining free-space complex block: C C Adding the free-space complex block: DO 20 J=KCB(NCB),NCB+1,-1 KCB(J+1)=KCB(J) 20 CONTINUE DO 21 J=NCB,1,-1 KCB(J)=KCB(J)+1 21 CONTINUE L=KCB(NCB) NCB=NCB+1 KCB(NCB)=L C C Creating the list of free-space simple blocks: C List of all simple blocks: DO 22 J=1,NSB KCB(L+J)=J 22 CONTINUE C Removing material simple blocks from the list: DO 23 J=NCB+1,L IF(KCB(L+KCB(J)).EQ.0) THEN WRITE(LU1,'(A,I3,A)') 'Simple block',KCB(J), * ' is situated in two different complex blocks!' ELSE KCB(L+KCB(J))=0 END IF 23 CONTINUE C List of remaining (i.e. free-space) simple blocks: DO 24 J=1,NSB IF(KCB(L+J).NE.0) THEN KCB(NCB)=KCB(NCB)+1 KCB(KCB(NCB))=KCB(L+J) END IF 24 CONTINUE C IF(KCB(NCB).EQ.L) THEN WRITE(LU1,'(A)') * 'There is no explicitly defined free space in the model.' ELSE WRITE(LU1,'(A)') 'Free space is composed of simple blocks:' WRITE(LU1,'(20I4)') (KCB(J),J=L+1,KCB(NCB)) END IF WRITE(LU1,'(A)') C C....................................................................... C WRITE(*,'(A)') '+Logical test for undefined free-space blocks. ' WRITE(LU1,'(2A)') 'Undefined free-space simple blocks ', * '(indices of surfaces limiting each one):' NUNDEF=0 C NUB=1 KUB(NUB)=0 DO 30 I=1,NSB KUB(NUB+I)=I 30 CONTINUE C 40 CONTINUE IF(NUB.LT.0) THEN C No candidates for undefined free-space simple block left: GO TO 70 END IF C KUBNUB=KUB(NUB) IF(KUBNUB.GE.NSB) THEN C Printing undefined free-space simple block: I=NUB DO 41 J=NUB+1,NUB+NSB IF(KUB(J).NE.0) THEN I=I+1 KUB(I)=KUB(J) END IF 41 CONTINUE NUNDEF=NUNDEF+1 WRITE(LU1,'(20I4/99(4X,20I4))') (KUB(J),J=NUB+1,I) NUB=NUB-NSB-1 GO TO 40 END IF C C Selecting simple block with minimum number MININT of C intersections: MININT=999999 C Loop over simple blocks DO 55 K=NUB+KUBNUB+1,NUB+NSB ISB=KUB(K) NUMINT=0 C Loop over surfaces limiting the simple block C (each surface separates the simple block from its complement) DO 53 J=KSB(ISB-1)+1,KSB(ISB) ISRF=KSB(J) C Loop over surfaces limiting the candidate DO 51 I=NUB+1,NUB+KUBNUB IF(KUB(I).EQ.ISRF) THEN C Empty intersection of the candidate and the complement GO TO 52 ELSE IF(KUB(I).EQ.-ISRF) THEN C The candidate is a subset of the complement NUMINT=1 NUMSUB=1 GO TO 54 END IF 51 CONTINUE NUMINT=NUMINT+1 52 CONTINUE 53 CONTINUE NUMSUB=0 54 CONTINUE IF(NUMINT.LT.MININT) THEN MININT=NUMINT MINSUB=NUMSUB MINKUB=K END IF 55 CONTINUE C IF(MININT.EQ.0) THEN C Candidate discarded: NUB=NUB-NSB-1 ELSE IF(MINSUB.GT.0) THEN C The candidate is a subset of one of the complements: KUB(MINKUB)=KUB(NUB+KUBNUB+1) KUB(NUB)=KUBNUB+1 KUB(NUB+KUBNUB+1)=0 ELSE C Candidate is intersected with each complement: ISB=KUB(MINKUB) KUB(MINKUB)=KUB(NUB+KUBNUB+1) KUB(NUB)=KUBNUB+1 C Candidate is MININT times reproduced IF(NUB+(ISB+1)*MININT-1.GT.MUB) THEN C MODCHK-04 CALL ERROR('MODCHK-04: Array dimension MUB too small') END IF DO 60 I=NUB+NSB+1,NUB+(NSB+1)*MININT-1 KUB(I)=KUB(I-NSB-1) 60 CONTINUE C Loop over surfaces limiting the simple block C (each surface separates the simple block from its complement) K=NUB DO 63 J=KSB(ISB-1)+1,KSB(ISB) ISRF=KSB(J) C Loop over surfaces limiting the candidate DO 61 I=K+1,K+KUBNUB IF(KUB(I).EQ.ISRF) THEN C Empty intersection of the candidate and the complement GO TO 62 END IF 61 CONTINUE KUB(NUB+KUBNUB+1)=-ISRF NUB=NUB+NSB+1 62 CONTINUE 63 CONTINUE NUB=NUB-NSB-1 END IF GO TO 40 C 70 CONTINUE C IF(NUNDEF.LE.0) THEN WRITE(LU1,'(A)') * 'O.K. There is no undefined free space in the model.' ELSE WRITE(LU1,'(2A)') 'Please, check carefully the above list ', * 'and edit the data for simple blocks!' END IF WRITE(LU1,'(A)') C C....................................................................... C C Test for overlapping simple blocks or complex blocks: C IF(N1.LE.0.AND.N2.LE.0.AND.N3.LE.0) THEN WRITE(LU1,'(A)') * 'Numerical test for overlapping blocks not performed.' ELSE WRITE(*,'(A)') '+ 0% Numerical test for overlapping blocks. ' C IF(LOVER) THEN WRITE(LU1,'(A)') * 'Overlapping simple blocks are allowed in the model,' WRITE(LU1,'(A)') * 'test for overlapping simple blocks is not performed!' WRITE(LU1,'(A)') WRITE(LU1,'(2A)') * 'List of points situated in more than one complex block', * ' (0=free space):' ELSE WRITE(LU1,'(A)') * 'List of points situated in more than one simple block:' END IF C I123=0 N123=(N1+1)*(N2+1)*(N3+1) DO 83 I3=0,N3 IF(N3.LE.0) THEN COOR(3)=(BOUNDM(5)+BOUNDM(6))/2. ELSE COOR(3)=BOUNDM(5)+(BOUNDM(6)-BOUNDM(5))*FLOAT(I3)/FLOAT(N3) END IF DO 82 I2=0,N2 IF(N2.LE.0) THEN COOR(2)=(BOUNDM(3)+BOUNDM(4))/2. ELSE COOR(2)=BOUNDM(3) * +(BOUNDM(4)-BOUNDM(3))*FLOAT(I2)/FLOAT(N2) END IF DO 81 I1=0,N1 IF(N1.LE.0) THEN COOR(1)=(BOUNDM(1)+BOUNDM(2))/2. ELSE COOR(1)=BOUNDM(1) * +(BOUNDM(2)-BOUNDM(1))*FLOAT(I1)/FLOAT(N1) END IF CALL CHK(COOR,NB,IB,LOVER) C Subroutine CHK IF(NB.GT.1.OR.(LFREE.AND.NB.LT.1)) THEN WRITE(LU1,'(3F9.3,3X,15I3/(30X,15I3))') * (COOR(I),I=1,3),(IB(I),I=1,NB) END IF C Displaying progress on the console: I123=I123+100 IF(MOD(I123,N123).LT.100) THEN WRITE(*,'(A,I3)') '+',I123/N123 END IF 81 CONTINUE 82 CONTINUE 83 CONTINUE C WRITE(LU1,'(A)') '---------' END IF CLOSE(LU1) WRITE(*,'(A)') '+Done. ' STOP END C C======================================================================= C C C SUBROUTINE CHK(COOR,NB,IB,LOVER) REAL COOR(3) INTEGER NB,IB(*) LOGICAL LOVER C C This is an auxiliary subroutine to program MODCHK. It determines the C position of a given point with respect to all simple (LOVER=.FALSE.) C or complex (LOVER=.TRUE.) blocks. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C LOVER...Logical value indicating whether the overlapping simple C blocks are allowed in the model. C LOVER=.FALSE.: Simple blocks containing the given point C are reported. C LOVER=.TRUE.: Complex blocks containing the given point C are reported. C None of the input parameters are altered. C C Output: C NB... Number of blocks inside which the given point is situated. C IB(1:NB)... Indices of blocks inside which the given point is C situated. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL NSRFC,SRFC2 INTEGER NSRFC C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1996, September 30 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER ISB,ICB,I REAL F(10),F1(100) C C....................................................................... C C Values of functions describing the surfaces in the model: DO 11 I=1,NSRFC() CALL SRFC2(I,COOR,F) F1(I)=F(1) 11 CONTINUE C C Loop for simple blocks: NB=0 DO 29 ISB=1,NSB C Loop for surfaces bounding simple block ISB: DO 21 I=KSB(ISB-1)+1,KSB(ISB) IF(F1(IABS(KSB(I)))*FLOAT(KSB(I)).LE.0.) THEN C The point is not inside the simple block. GO TO 25 END IF 21 CONTINUE C The point is inside the simple block. NB=NB+1 IB(NB)=ISB 25 CONTINUE 29 CONTINUE C IF (LOVER.AND.NB.GT.0) THEN C Loop for simple blocks inside which the point is situated: DO 39 ISB=1,NB C Loop for complex blocks: DO 32 ICB=1,NCB C Loop for simple blocks composing complex block ICB: DO 31 I=KCB(ICB-1)+1,KCB(ICB) IF(KCB(I).EQ.IB(ISB)) THEN C The point is inside the complex block. IB(ISB)=ICB GO TO 35 END IF 31 CONTINUE 32 CONTINUE 35 CONTINUE 39 CONTINUE C Removing identical complex blocks: ICB=1 DO 49 ISB=2,NB DO 42 I=1,ICB IF(IB(ISB).EQ.IB(I)) THEN C Repeated index of complex block. GO TO 45 END IF 42 CONTINUE ICB=ICB+1 IB(ICB)=IB(ISB) 45 CONTINUE 49 CONTINUE NB=ICB C Renaming free-space complex block from NCB to 0: DO 51 ICB=1,NB IF(IB(ICB).EQ.NCB) THEN IB(ICB)=0 END IF 51 CONTINUE 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 INCLUDE 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for C C======================================================================= Cmodelerr.htm 0100666 0000765 0000765 00000016024 07305626410 012762 0 ustar bulant bulant
C Subroutine file 'model.for' to specify a seismic model. C C Date: 1999, December 6 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following external procedures: C MODEL1..Subroutine designed to read the input data for the C description of the model and to store them in the memory. C Subroutine MODEL1 reads the input data (1)-(8) listed C below itself, then calls subroutine SRFC1 (included in the C subroutine file 'srfc.for') to read the input data (9) for C smooth surfaces, and finally calls subroutine PARM1 C (included in the subroutine file 'parm.for') to read the C input data (10) for the parameters of the medium. C MODEL1 C NSRFC...Integer function returning the number of surfaces covering C structural interfaces. C NSRFC C BLOCK...Subroutine designed to determine the mutual position of a C point and a simple and a complex block. Just calls more C general subroutine BLOCKS which does the job. C BLOCK C BLOCKS..Subroutine designed to determine the mutual position of a C point and a simple and a complex block. A more general C version of subroutine BLOCK, designed especially to work C with curves situated at structural interfaces. C BLOCKS C ISIDE...Auxiliary function to subroutine BLOCKS. C ISIDE C INTERF..Auxiliary subroutine to subroutine BLOCKS. C INTERF C SEPAR...Subroutine determining the surface separating two given C simple blocks. C SEPAR C VELOC...Subroutine transforming the values of a medium parameters C into velocities and loss factors. C VELOC C FPOWER..Subroutine evaluating the value and, possibly, the three C first and six second partial derivatives of a function, C if the value and the three first and six second partial C derivatives of the POWER-th power of the function are C known. Particularly, this is an auxiliary subroutine C to the subroutine VELOC. C FPOWER C C Note: C The lines denoted by '*V' in the first two columns of file C 'model.for' in subroutines VELOC and FPOWER are designed to C calculate the model variations with respect to the model C parameters. C File 'modelv.for', intended for the model inversion, is created C from 'model.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C C....................................................................... C C C Input data MODEL for the specification of the model: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new READ statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise (except TEXTM), the input parameter is of the C type REAL. C (1) TEXTM C The string containing the name of the model. Only the first 80 C characters of the string are significant. C (2) KOORS,NEXPV,NEXPQ,IVERT,/ C KOORS...Specifies the type of the coordinate system: C KOORS.LE.0: Cartesian coordinates (default). C KOORS.EQ.1: polar spherical coordinates in radians, C (X1,X2,X3)=(colatitude,longitude,radius). C KOORS.GE.2: geographic spherical coordinates in radians, C (X1,X2,X3)=(longitude,latitude,radius). C If the coordinate system is right-handed (recommended), C all vectorial products are evaluated using the right-hand C rule, otherwise using the left-hand rule. C KOORS is passed to the subroutines of file 'metric.for' C by means of invocation of subroutine METR1 and presently C represents the only input data for the coordinate system. C Note that possible future additional data for the C coordinate system should be read by subroutine METR1 and C should be located between input data (2) and (3). C metric.for C NEXPV,NEXPQ... The default values are highly recommended! C Velocities powered to NEXPV and loss factors powered to C NEXPQ are reported by the subroutines evaluating isotropic C material parameters. C For example, unit values of NEXPV and NEXPQ indicate that C velocities and loss factors are the output parameters C of the subroutines evaluating isotropic material C parameters, indices equal -1 indicate reciprocal values of C these quantities, i.e. slownesses and quality factors. C When using the basic submitted version of the subroutine C file 'parm.for', the default values of NEXPV=1, NEXPQ=1 C are highly recommended. Other values make sense only if a C user is submitting his own subroutines to evaluate C isotropic material parameters which, e.g., output the C slowness instead of the velocity. In such a case, C switching NEXPV from 1 to -1 may avoid the modification C of the user's subroutines. C IVERT...Orientation of the vertical axis: C IVERT=0: unknown (default), C IVERT=+1: X1 vertical, pointing upwards, C IVERT=-1: X1 vertical, pointing downwards, C IVERT=+2: X2 vertical, pointing upwards, C IVERT=-2: X2 vertical, pointing downwards, C IVERT=+3: X3 vertical, pointing upwards, C IVERT=-3: X3 vertical, pointing downwards, C Has no influence on the calculations, and need not be C specified. If it is non-zero, it may be considered for C plotting purposes. C /... Obligatory slash at the end of line for future extensions. C Default: KOORS=0, NEXPV=1, NEXPQ=1, IVERT=0. C (3) X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX C Boundaries of the model. C (4) NSRFC C Number of smooth surfaces in the model. The surfaces are indexed C sequentially in any order by positive integers ISRFC from 1 to C NSRFC. C It is recommended to define only surfaces covering structural C interfaces (model surfaces) in this data set. Auxiliary surfaces C related to particular source-receiver configurations, numerical C procedures, etc., should preferably be defined in other data sets. C (5) NSB C Number of simple blocks in the model, defined in this data set. C The defined blocks are indexed sequentially by positive integers C ISB from 1 to NSB in the same order as they are specified in data C (6). Intersecting simple blocks are allowed but not recommended. C All material simple blocks in the model must be defined. C Free-space blocks need not be defined in this data set but it is C recommended to define the free-space simple blocks in order to C speed up the determination of a free space during computations. C Defined free-space blocks also enhance the possibility to check C for the model consistency. If the free-space simple blocks are C not, for some reason, defined here, they may be defined in the C additional data file designed just for the consistency check by C program modchk.for C (6) NSB input operations (READ statements): C For each simple block with index ISB, the indices of the surfaces C forming the set F(+) and the indices of the surfaces forming the C set F(-). The indices of surfaces from F(+) must be positive, the C indices of surfaces from F(-) must be indicated by negative signs. C The indices may be specified in an arbitrary order and must be C terminated by a slash. C (7) NCB C Number of material complex blocks in the model. The material C complex blocks are indexed sequentially by positive integers ICB C from 1 to NCB. The free-space complex block is not indexed and C consists of all simple blocks not contained in the material C complex blocks. Space covered by no simple block is also deemed C to be a free space. C (8) NCB input operations (READ statements): C For each material complex block, the indices of material simple C blocks forming the complex block. The indices may be specified C in an arbitrary order and must be terminated by a slash. C Each material simple block must appear exactly once within these C data lines. Simple blocks defined by data (6) but not listed here C are deemed to be free-space simple blocks. C (9) The data specifying NSRFC functions F(X1,X2,X3) describing the C smooth surfaces in the model. The data are read by subroutine C SRFC1. For their description refer to subroutine SRFC1 (included C in the subroutine file 'srfc.for'). C srfc.for: Input data C (10) The data specifying the distribution of parameters of the model C in all NCB material complex blocks. The data are read by C subroutine PARM1. For their description refer to subroutine C PARM1 (included in the subroutine file 'parm.for'). C parm.for: Input data C For an example refer to the sample input data for the model. C Example of data set MODEL C C C Input data in the form of SEP C parameter or history file: C NEGPAR=integer... Flag whether the negative values of material C parameters are allowed: C NEGPAR=0: Negative values of material parameters or zero C P-wave velocity are reported as errors. C NEGPAR=1: Negative values of material parameters or zero C P-wave velocity are not reported as errors. C Default: NEGPAR=0 C C....................................................................... C C Storage in the memory: C The input data (1) to (8) describing the structure of the model C are stored in common blocks /MODELT/ and /MODELC/ defined in the C include file 'model.inc'. C model.inc C C======================================================================= C C C SUBROUTINE MODEL1(LUN) INTEGER LUN C C Subroutine MODEL1 reads the input data (1)-(8) for the description C of the model and stores them in common blocks /MODELT/ and /MODELC/. C Then it calls subroutine SRFC1 (included in the subroutine file C 'srfc.for') to read the input data (9) for smooth surfaces and to C store them in the memory. Finally, it calls subroutine PARM1 C (included in the subroutine file 'parm.for') to read the input data C (10) for the parameters of the medium and to store them in the memory. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C The input parameter is not altered. C C No output. C C Common blocks /MODELT/ and /MODELC/: INCLUDE 'model.inc' C model.inc C All the storage locations of the common blocks are defined in this C subroutine. C C Subroutines and external functions required: EXTERNAL RSEP3I,METR1,SRFC1,PARM1 C RSEP3I...File 'sep.for'. C METR1...File 'metric.for'. C SRFC1 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C PARM1 and subsequent routines... File 'parm.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1999, August 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I,J,L C READ(LUN,*) TEXTM I=0 NEXPV=1 NEXPQ=1 IVERT=0 READ(LUN,*) I,NEXPV,NEXPQ,IVERT CALL METR1(I) READ(LUN,*) BOUNDM READ(LUN,*) NSRFCS C C Simple blocks: C Number of simple blocks READ(LUN,*) NSB C Initializing memory for indices of surfaces bounding simple blocks L=NSB+1 DO 11 I=L,MSB KSB(I)=0 11 CONTINUE C Reading indices of surfaces bounding simple blocks: DO 14 J=1,NSB READ(LUN,*) (KSB(I),I=L,MSB) DO 12 I=L,MSB IF(IABS(KSB(I)).GT.NSRFCS) THEN C 311 CALL ERROR('311 in MODEL: Block bounded by wrong interface') C Index of the surface bounding the simple block is greater C than the specified number of surfaces. ELSE IF(KSB(I).EQ.0) THEN KSB(J)=I-1 L=I GO TO 13 END IF 12 CONTINUE GO TO 99 13 CONTINUE 14 CONTINUE C C Complex blocks: C Number of complex blocks READ(LUN,*) NCB C Initializing memory for indices of simple blocks forming c. blocks L=NCB+1 DO 21 I=L,MCB KCB(I)=0 21 CONTINUE C Reading indices of simple blocks forming complex blocks DO 24 J=1,NCB READ(LUN,*) (KCB(I),I=L,MCB) DO 22 I=L,MCB IF(KCB(I).LT.0.OR.KCB(I).GT.NSB) THEN C 312 CALL ERROR * ('312 in MODEL: C. block composed of wrong s. block.') C Complex block composed of wrong simple block: C Index of a simple block composing the complex block is C greater than the specified number of simple blocks. ELSE IF(KCB(I).EQ.0) THEN KCB(J)=I-1 L=I GO TO 23 END IF 22 CONTINUE GO TO 99 23 CONTINUE 24 CONTINUE C C Smooth surfaces: CALL SRFC1(LUN,NSRFCS) C C Material parameters: CALL PARM1(LUN,NCB) CALL RSEP3I('NEGPAR',NEGPAR,0) RETURN C 99 CONTINUE C 310 CALL ERROR('310 in MODEL1: Insufficient memory in /MODELC/') C Insufficient memory for the input data in common block /MODELC/. C The dimensions MSB or MCB of arrays KSB or KCB, respectively, C must be enlarged. C Refer to include file model.inc END C C======================================================================= C C C INTEGER FUNCTION NSRFC() C C Integer function NSRFC is designed to return the number of surfaces C covering structural interfaces. C C No input. C C Output: C NSRFC...Number of surfaces covering structural interfaces. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1989, December 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C No auxiliary storage locations. C NSRFC=NSRFCS RETURN END C C======================================================================= C C C SUBROUTINE BLOCK(COOR,ISRF1,ISB1,ISRF2,ISB2,ICB2) REAL COOR(3) INTEGER ISRF1,ISB1,ISB2,ICB2,ISRF2 C C This subroutine searches for the simple block and the complex block in C which a given point is situated. This routine may be also used to C determine the index of a block touching a specified block at a given C point situated on the boundary of the specified block (the situation C which may occur when a ray impinges on a boundary of a block). C Another function of the routine is to determine the index of the C surface bounding a given simple block and separating it from the given C point. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C ISRF1...Controls the possible determination of the simple block C touching block ISB1 at the given point. C ISRF1.EQ.0: The simple block touching ISB1 at the given C point need not be determined. This is the most frequent C option, used, e.g., if the given point is not situated C at a structural interface or if the simple block C touching ISB1 is already known. C ISRF1.NE.0: Index of the surface at which the given point C is situated and which separates simple block ISB1 from C another block to be determined and returned in ISB2. C Since the given point may be situated on either side of C the surface, surface IABS(ISRF1) is skipped in the list C of surfaces limiting simple blocks when determining the C position of the given point with respect to simple C blocks. The sign of ISRF1 is ignored. C This option cannot be used together with ISB1.EQ.0. C ISB1... Index of the simple block which position with respect to C the given point will be checked. C ISB1.EQ.0: No simple block given. The simple block in C which the given point is situated will be determined C and returned in ISB2. ISRF2 will be set to zero. C The determination starts with initial estimate ISBOLD, C continuing with ISBOLD+1, ISBOLD-1, ISBOLD+2, ISBOLD-2, C etc. Here ISBOLD is the simple block returned in ISB2 C during the last invocation of this subroutine with C ISB1.EQ.0 on input and ISB2.NE.0 on output. ISBOLD=1 C before such an invocation. C ISB1.GT.0: The position of the given point with C respect to simple block ISB1 will be examined. C If the point is situated in ISB1, the output value C of ISRF2 is set to 0. C If the point is situated in ISB1 and ISRF1.EQ.0, C the output value of ISB2 is set to ISB1. C If the point is situated in ISB1 and ISRF1.NE.0, C the simple block containing the given point, C separated from block ISB1 by surface ISRF1 and not C separated from block ISB1 by another surface will be C determined and returned in ISB2. C If the point is not situated in ISB1, the surface C separating the point from ISB1 is output in ISRF2. C In addition, the simple block containing the given C point, separated from block ISB1 by surface ISRF2 and C not separated from block ISB1 by another surface will C be determined and returned in ISB2. C The determination starts with initial estimate ISB1, C continuing with ISB1+1, ISB1-1, ISB1+2, ISB1-2, etc. C None of the input parameters are altered. C C Output: C ISRF2...For the given point not situated inside block ISB1 or C at its boundary, ISRF2 has the meaning of the index of C one of the surfaces bounding simple block ISB1 and C separating the given point from simple block ISB1, C supplemented by a sign '+' or '-' for the simple block C ISB1 situated at the positive or negative side of the C surface, respectively. If the point is separated from C simple block ISB1 by several surfaces, the first one of C the surfaces, for which ISB2 (see description of ISB2 C below) will be positive, is preferred. Roughly speaking, C surface ISRF2 at which simple block ISB1 touches simple C block containing the given point is preferred. C ISRF2=0 if ISB1=0 or if the given point is situated inside C block ISB1 or at its boundary. C If ISRF1.NE.0, the position with respect to surface C IABS(ISRF1) is not checked. C ISB2... Index of the simple block containing the given point. C If ISB1.EQ.0: C ISB2 is the index of the simple block containing the C given point. C The first simple block of ISBOLD, ISBOLD+1, ISBOLD-1, C ISBOLD+2, ISBOLD-2, etc., containing the given point, C is returned in ISB2. Here ISBOLD is the simple block C returned in ISB2 during the previous invocation of this C subroutine with ISB1.EQ.0. ISBOLD=1 during such the C first invocation. C If ISB1.NE.0: C If ISRF1.EQ.0 and ISRF2.EQ.0, ISB2 must not be C separated from simple block ISB1 by any surface. C A surface "separates" two simple blocks if both blocks C are bounded by the surface and are situated at its C opposite sides. C If ISRF1.NE.0 and ISRF2.EQ.0, ISB2 must be separated C from simple block ISB1 by surface IABS(ISRF1) and C must not be separated by another surface. C If ISRF2.NE.0, ISB2 must be separated from simple block C ISB1 by surface ISRF2 and must not be separated by C another surface. C The first simple block of ISB1, ISB1+1, ISB1-1, C ISB1+2, ISB1-2, etc., having the above properties, is C returned in ISB2. C If there is no simple block of the above properties, C ISB2=0. C ICB2... Index of the complex block in which simple block ISB2 is C situated. ICB2=0 if ISB2=0 or if simple block ISB2 is not C situated in any material complex block. C C Examples: C For each point of a set of discrete points, we wish to determine C simple block ISB and complex block ICB in which the point C is situated. C (a) We thus use C CALL BLOCK(COOR,0,0,I,ISB,ICB) C When tracing a curve (e.g., a ray), we wish rather to find each C crossed interface than only to determine the simple blocks C at discrete points along the curve. C (b) If the previous point along the curve is situated in C simple block ISB, we use C CALL BLOCK(COOR,0,ISB,ISRF1,ISBNEW,ICBNEW) C and get ISRF1.EQ.0 if no surface limiting simple block ISB C has been crossed. C (c) If ISRF1.NE.0, IABS(ISRF1) is the surface which has been C crossed. We should determine the point of intersection of C the curve with surface IABS(ISRF1). Then we use C CALL BLOCK(COOR,ISRF1,ISB,ISRF2,ISB2,ICB2) C to find simple block ISB2 and complex block ICB2 at the C other side of surface ISRF1. If ISRF2.EQ.0, the blocks C are successfully determined. If ISRF2.NE.0, surface C IABS(ISRF2) has also been crossed and we have to repeat C step (c) with ISRF1=ISRF2. C When tracing a curve along surface ISRFA, we call subroutine C BLOCKS instead of BLOCK, with analogous arguments: C (b') ISRF(1)=0 C ISRF(2)=ISRFA C CALL BLOCKS(COOR,2,ISRF,ISB,ISRF1,ISBNEW,ICBNEW) C (c') ISRF(1)=ISRF1 C ISRF(2)=ISRFA C CALL BLOCKS(COOR,2,ISRF,ISB,ISRF2,ISB2,ICB2) C Analogously, when tracing the curve of intersection of surfaces C ISRFA and ISRFB, we call subroutine BLOCKS in the C following way: C (b") ISRF(1)=0 C ISRF(2)=ISRFA C ISRF(3)=ISRFB C CALL BLOCKS(COOR,3,ISRF,ISB,ISRF1,ISBNEW,ICBNEW) C (c") ISRF(1)=ISRF1 C ISRF(2)=ISRFA C ISRF(3)=ISRFB C CALL BLOCKS(COOR,3,ISRF,ISB,ISRF2,ISB2,ICB2) C C Subroutines and external functions required: EXTERNAL BLOCKS C BLOCKS... This file. C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C INTEGER ISRF(1) C ISRF(1)=ISRF1 CALL BLOCKS(COOR,1,ISRF,ISB1,ISRF2,ISB2,ICB2) RETURN END C C======================================================================= C C C SUBROUTINE BLOCKS(COOR,NSRF1,ISRF,ISB1,ISRF2,ISB2,ICB2) REAL COOR(3) INTEGER NSRF1,ISRF(NSRF1),ISB1,ISRF2,ISB2,ICB2 C C This subroutine is a generalization of subroutine BLOCK to follow C points along structural interfaces and edges. Subroutine BLOCKS C searches for the simple block and the complex block in which a given C point is situated. The given point may be situated in the vicinity C of one or more structural interfaces. In such case, blocks at the C proper side of the interface(s) will be searched for. This routine C may also be used to determine the index of a block touching a C specified block at a given point situated on the boundary of the C specified block (the situation which may occur when a ray impinges on C a boundary of a block). Another function of the routine is to C determine the index of the surface bounding a given simple block and C separating it from the given point. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C NSRF1...Number of surface indices specified in array ISRF. C There must be NSRF1.GE.1. For ISB1.EQ.0., there must be C NSRF1.EQ.1 and ISRF(1).EQ.0. C ISRF... Array containing the indices of the surfaces at which the C given point is situated. Since the given point may be C situated on either side of the surfaces, the surfaces C listed in array ISRF are skipped in the list of surfaces C limiting simple blocks when determining the position of C the given point with respect to simple blocks. C The signs of the indices in array ISRF are ignored. C ISRF(1): Controls the possible determination of the C simple block touching block ISB1 at the given point. C ISRF(1).EQ.0: The simple block touching ISB1 at the C given point need not be determined. This is the most C frequent option, used, e.g., if the given point is not C situated at a structural interface or if the simple C block touching ISB1 is already known. C ISRF(1).NE.0: Index of the surface at which the given C point is situated and which separates simple block C ISB1 from another block to be determined. Refer to C the description of output parameter ISB2. C This option cannot be used together with ISB1.EQ.0. C ISRF(2) to ISRF(NSRF1): Indices of the surfaces at C which the given point is situated, other than ISRF(1). C These indices are designed to specify the surface along C which a curve is traced, or the surfaces which curve of C intersection is traced. C ISB1... Index of the simple block which position with respect to C the given point will be checked. C ISB1.EQ.0: No simple block given. The simple block in C which the given point is situated will be determined C and returned in ISB2. ISRF2 will be set to zero. C The determination starts with initial estimate ISBOLD, C continuing with ISBOLD+1, ISBOLD-1, ISBOLD+2, ISBOLD-2, C etc. Here ISBOLD is the simple block returned in ISB2 C during the last invocation of this subroutine with C ISB1.EQ.0 and ISB2.NE.0. ISBOLD=1 before such an C invocation. C ISB1.GT.0: The position of the given point with C respect to simple block ISB1 will be examined. C If the point is situated in ISB1, the output value C of ISRF2 is set to 0. C If the point is situated in ISB1 and ISRF(1).EQ.0, C the output value of ISB2 is set to ISB1. C If the point is situated in ISB1 and ISRF(1).NE.0, C the simple block containing the given point, C separated from block ISB1 by surface ISRF(1) and not C separated from block ISB1 by another surface will be C determined and returned in ISB2. C If the point is not situated in ISB1, the surface C separating the point from ISB1 is output in ISRF2. C In addition, the simple block containing the given C point, separated from block ISB1 by surface ISRF2 and C not separated from block ISB1 by another surface will C be determined and returned in ISB2. C The determination starts with initial estimate ISB1, C continuing with ISB1+1, ISB1-1, ISB1+2, ISB1-2, etc. C None of the input parameters are altered. C C Output: C ISRF2...For the given point not situated inside block ISB1 or C at its boundary, ISRF2 has the meaning of the index of C one of the surfaces bounding simple block ISB1 and C separating the given point from simple block ISB1, C supplemented by a sign '+' or '-' for the simple block C ISB1 situated at the positive or negative side of the C surface, respectively. If the point is separated from C simple block ISB1 by several surfaces, the first one with C positive ISB2 (see below) is preferred. C ISRF2=0 if ISB1=0 or if the given point is situated inside C block ISB1 or at its boundary. C Note that surfaces ISRF(1) to ISRF(NSRF1) are skipped C when determining the position of the given point with C respect to simple blocks. C ISB2... Index of the simple block containing the given point. C If ISB1.EQ.0: C ISB2 is the index of the simple block containing the C given point. C The first simple block of ISBOLD, ISBOLD+1, ISBOLD-1, C ISBOLD+2, ISBOLD-2, etc., containing the given point, C is returned in ISB2. Here ISBOLD is the simple block C returned in ISB2 during the previous invocation of this C subroutine with ISB1.EQ.0. ISBOLD=1 during such the C first invocation. C If ISB1.NE.0: C If ISRF(1).EQ.0 and ISRF2.EQ.0, ISB2 must not be C separated from simple block ISB1 by any surface. C A surface "separates" two simple blocks if both blocks C are bounded by the surface and are situated at its C opposite sides. C If ISRF(1).NE.0 and ISRF2.EQ.0, ISB2 must be separated C from simple block ISB1 by surface IABS(ISRF(1)) and C must not be separated by another surface. C If ISRF2.NE.0, ISB2 must be separated from simple block C ISB1 by surface ISRF2 and must not be separated by C another surface. C The first simple block of ISB1, ISB1+1, ISB1-1, C ISB1+2, ISB1-2, etc., having the above properties, is C returned in ISB2. C If there is no simple block of the above properties, C ISB2=0. C ICB2... Index of the complex block in which simple block ISB2 is C situated. ICB2=0 if ISB2=0 or if simple block ISB2 is not C situated in any material complex block. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL ISIDE,INTERF,SRFC2 INTEGER ISIDE C ISIDE,INTERF... This file. C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MSEPAR PARAMETER (MSEPAR=20) INTEGER NSEPAR,KSEPAR(MSEPAR),JSEPAR,ISEPAR,ISIDE1,I,J,K,II(1) INTEGER ISBOLD,ISB0,ISRF1 SAVE ISBOLD DATA ISBOLD/1/ C C....................................................................... C ISRF1=ISRF(1) C C Checking input values: IF(ISRF1.LT.-NSRFCS.OR.ISRF1.GT.NSRFCS) THEN C 313 CALL ERROR('313 in BLOCK: Wrong index of surface') C Absolute value of the input parameter ISRFC1 (index of the C surface) is greater than the number NSRFC of the surfaces C covering structural interfaces. END IF IF(ISB1.LT.0.OR.ISB1.GT.NSB) THEN C 314 CALL ERROR('314 in BLOCK: Wrong index of simple block') C Parameter ISB1 (index of the simple block) is either C negative or greater than the number NSB of simple blocks. END IF IF(ISB1.EQ.0) THEN IF(NSRF1.NE.1.OR.ISRF1.NE.0) THEN C 315 CALL ERROR('315 in BLOCK: No simple block specified') C If no simple block ISB1 is specified, NSRF1 must be 1 and C ISRF1=ISRF(1) must be 0. END IF END IF C C Initial simple block ISB0: IF(ISB1.EQ.0) THEN ISB0=ISBOLD ELSE ISB0=ISB1 END IF C C Position of the given point with respect to simple block ISB0: ISRF2=0 CALL INTERF(COOR,NSRF1,ISRF,ISB0,MSEPAR,NSEPAR,KSEPAR) IF(NSEPAR.EQ.0) THEN C The point is inside simple block ISB0: IF(ISRF1.EQ.0) THEN ISB2=ISB0 GO TO 90 ELSE NSEPAR=1 KSEPAR(1)=ISRF1 END IF ELSE IF(ISB1.EQ.0) THEN NSEPAR=1 ELSE ISRF2=KSEPAR(1) END IF END IF C C Search for the simple block in which the given point is situated: DO 20 JSEPAR=1,NSEPAR IF(ISB1.NE.0) THEN ISEPAR=IABS(KSEPAR(JSEPAR)) ISIDE1=-ISIDE(ISEPAR,ISB1) END IF C Loop over simple blocks DO 19 J=1,MAX0(ISB0-1,NSB-ISB0) DO 18 ISB2=ISB0+J,ISB0-J,-2*J IF(ISB2.GT.0.AND.ISB2.LE.NSB) THEN C Selecting simple block ISB2 according to ISB1 IF(ISB1.NE.0) THEN C Loop for surfaces bounding block ISB1 DO 11 I=KSB(ISB1-1)+1,KSB(ISB1) C Skipping simple blocks separated from ISB1 by another C surface than ISEPAR K=KSB(I) IF(IABS(K).NE.ISEPAR) THEN IF(ISIDE(K,ISB1).EQ.-ISIDE(K,ISB2)) THEN GO TO 17 END IF END IF 11 CONTINUE C Skipping simple blocks not separated from ISB1 by ISEPAR IF(ISIDE(ISEPAR,ISB2).NE.ISIDE1) THEN GO TO 17 END IF END IF C Determining the position of the given point with respect C to the simple block CALL INTERF(COOR,NSRF1,ISRF,ISB2,1,I,II) IF(I.EQ.0) THEN IF(ISB1.EQ.0) THEN ISBOLD=ISB2 ELSE ISRF2=KSEPAR(JSEPAR) END IF GO TO 90 END IF 17 CONTINUE END IF 18 CONTINUE 19 CONTINUE 20 CONTINUE C No simple block has been found: ISB2=0 ICB2=0 RETURN C C Determination of the complex block: 90 CONTINUE DO 92 J=1,NCB DO 91 I=KCB(J-1)+1,KCB(J) IF(KCB(I).EQ.ISB2) THEN ICB2=J RETURN END IF 91 CONTINUE 92 CONTINUE C No complex block: ICB2=0 RETURN END C C======================================================================= C C C INTEGER FUNCTION ISIDE(ISRF,ISB) INTEGER ISRF,ISB C C This is an auxiliary function to the subroutine BLOCKS. C This function determines the mutual position of a surface and a simple C block. C C Input: C ISRF... Index of the surface. The sign is ignored. C ISB... Index of the simple block. C None of the input parameters are altered. C C Output: C ISIDE...ISIDE=-1: The simple block is bounded by the surface and C is situated on its negative side. C ISIDE= 1: The simple block is bounded by the surface and C is situated on its positive side. C ISIDE= 2: The simple block is not bounded by the surface. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1989, December 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER IS,LS,MS C LS=KSB(ISB-1)+1 MS=KSB(ISB) C C Loop for surfaces bounding simple block ISB: DO 1 IS=LS,MS IF(IABS(KSB(IS)).EQ.IABS(ISRF)) THEN ISIDE=ISIGN(1,KSB(IS)) RETURN END IF 1 CONTINUE C ISIDE=2 RETURN END C C======================================================================= C C C SUBROUTINE INTERF(COOR,NSRF1,ISRF1,ISB,MSRF2,NSRF2,ISRF2) REAL COOR(3) INTEGER NSRF1,ISRF1(NSRF1),ISB,MSRF2,NSRF2,ISRF2(MSRF2) C C This is an auxiliary subroutine to the subroutine BLOCKS. C This subroutine determines the position of a given point with respect C to a given simple block. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C NSRF1...Number of surface indices specified in array ISRF1. C Must be NSRF1.GE.1. C ISRF1...Array containing the indices of the surfaces at which the C given point is situated. Since the given point may be C situated on either side of the surfaces, the surfaces C listed in array ISRF1 are skipped in the list of surfaces C limiting the simple block when determining the position of C the given point with respect to the simple block. C The signs of the indices in array ISRF1 are ignored. C Zero indices are allowed and have no neaning. C ISB... Index of the given simple block. C MSRF2...Dimension of array ISRF2. C None of the input parameters are altered. C C Output: C NSRF2...Number of surfaces separating the given point from simple C block ISB. C NSRF2=0 if the given point is situated inside simple C block ISB. C ISRF2...Indices of surfaces separating the given point from simple C block ISB, supplemented by sign '+' or '-' for simple C block ISB situated at the positive or negative side of the C surface, respectively. C The first MSRF2 such surfaces from the list of surfaces C limiting the simple block are reported. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL SRFC2 C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER IS,JS,KS,I REAL F(10) C F... Auxiliary array to contain the value and partial C derivatives F, F1, F3, F11, F12, F22, F13, F23, F33 of the C function describing surfaces at the given point. C C Speed-up storage locations: INTEGER MOLD PARAMETER (MOLD=20) INTEGER NOLD,IOLD(MOLD) REAL COLD(3) SAVE COLD,NOLD,IOLD DATA COLD/3*-999999./ C C....................................................................... C C Already examined surfaces: IF(COOR(1).NE.COLD(1).OR. * COOR(2).NE.COLD(2).OR.COOR(3).NE.COLD(3)) THEN NOLD=0 END IF C C Loop for surfaces bounding simple block ISB: NSRF2=0 DO 9 IS=KSB(ISB-1)+1,KSB(ISB) KS=KSB(IS) JS=IABS(KS) C Skipping surfaces of array ISRF1 DO 1 I=1,NSRF1 IF(JS.EQ.IABS(ISRF1(I))) THEN GO TO 8 END IF 1 CONTINUE C Surfaces already examined DO 2 I=1,NOLD IF(JS.EQ.IABS(IOLD(I))) THEN IF(IOLD(I)*KS.LT.0) THEN NSRF2=NSRF2+1 ISRF2(NSRF2)=KS IF(NSRF2.GE.MSRF2) THEN RETURN END IF END IF GO TO 8 END IF 2 CONTINUE C The surface has to be examined CALL SRFC2(JS,COOR,F) IF(NOLD.LT.MOLD) THEN IF(F(1).LT.0.) THEN NOLD=NOLD+1 IOLD(NOLD)=-JS ELSE IF(F(1).GT.0.) THEN NOLD=NOLD+1 IOLD(NOLD)= JS END IF END IF IF(F(1)*FLOAT(KS).LT.0.) THEN NSRF2=NSRF2+1 ISRF2(NSRF2)=KS IF(NSRF2.GE.MSRF2) THEN RETURN END IF END IF 8 CONTINUE 9 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE SEPAR(ISB1,ISB2,NSRF,ISRF) INTEGER ISB1,ISB2,NSRF,ISRF C C Subroutine determining the surface separating given simple blocks, C i.e., the surface limiting the simple blocks, which are situated one C at the positive side of the surface and the other at the negative side C of the surface. C C Input: C ISB1,ISB2... Indices of given simple blocks. C None of the input parameters are altered. C C Output: C NSRF... Number of surfaces separating the simple blocks. C ISRF... Index of a surface separating the simple blocks, C supplemented by sign minus if simple block ISB1 is C situated at its negative side. C If NSRF.EQ.0: ISRF contains unchanged input value. C If NSRF.GT.1: ISRF is one of the surfaces separating the C simple blocks. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1999, May 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I1,I2,KSBI2 C NSRF=0 C C Loop for surfaces bounding simple block ISB2 DO 2 I2=KSB(ISB2-1)+1,KSB(ISB2) KSBI2=-KSB(I2) C Loop for surfaces bounding simple block ISB1 DO 1 I1=KSB(ISB1-1)+1,KSB(ISB1) IF(KSB(I1).EQ.KSBI2) THEN NSRF=NSRF+1 IF(NSRF.EQ.1) THEN ISRF=KSB(I1) END IF END IF 1 CONTINUE 2 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE VELOC(IWAVE,UP,US,QP,QS,VP,VS,VD,QL) INTEGER IWAVE REAL UP(10),US(10),QP,QS,VP,VS,VD(10),QL C C This subroutine transforms the values of parameters of the medium into C velocities and loss factors. C C Input: C IWAVE...Type of wave. C IWAVE.GE.0: P wave, C IWAVE.LT.0: S wave. C UP,US...Powers of P and S wave velocities and their first and C second partial derivatives (the exponent of the powers is C NEXPV, see 'Input data for the model'), in order U, U1, C U2, U3, U11, U12, U22, U13, U23, U33. C QP,QS...Powers of the loss factors of P and S waves (the exponent C of the powers is NEXPQ, see 'Input data for the model'). C None of the input parameters are altered. C C Output: C VP,VS...P and S wave velocities. C VD... Velocity and its first and second partial derivatives C ordered as UP, US, corresponding to the wave specified by C IWAVE, in order V, V1, V2, V3, V11, V12, V22, V13, V23, C V33. C QL... Loss factor corresponding to the wave specified by IWAVE. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL FPOWER C FPOWER...This file. C C Date: 1992, December 31 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage location: REAL POWER,AUX1(1),AUX2(1) C POWER=FLOAT(NEXPV) IF(IWAVE.GE.0) THEN CALL FPOWER(10,UP,POWER,VD) *V CALL VAR5(1,1) VP=VD(1) CALL FPOWER(1,US,POWER,AUX2) VS=AUX2(1) AUX1(1)=QP ELSE CALL FPOWER(1,UP,POWER,AUX2) VP=AUX2(1) CALL FPOWER(10,US,POWER,VD) *V CALL VAR5(2,2) VS=VD(1) AUX1(1)=QS END IF CALL FPOWER(1,AUX1,FLOAT(NEXPQ),AUX2) QL=AUX2(1) RETURN END C C======================================================================= C C C SUBROUTINE FPOWER(N,FINP,POWER,FOUT) INTEGER N REAL FINP(N),POWER,FOUT(N) C C This subroutine evaluates the value and, possibly, the three first and C six second partial derivatives of a function if the value and the C three first and six second partial derivatives of the POWER-th power C of the function are known. C C Input: C N... For N=1: only the function value is evaluated. The C derivatives are ignored. C For N=4: the value and the three first partial derivatives C are evaluated. C For N=10: the value and the three first and six second C partial derivatives are evaluated. C FINP... Array containing the value, the first and second partial C derivatives of the POWER-th power of the function to be C evaluated, in the order F, F1, F2, F3, F11, F12, F22, F13, C F23, F33. For N=1, only the function value is required. C POWER...The specified function is equal to the POWER-th power of C the corresponding physical quantity. C POWER=0: Zero output array FOUT is generated. C None of the input parameters are altered (except FINP if this C parameter and FOUT are identical in the calling sequence). C C Output: C FOUT... Array containing the value, the first and second partial C derivatives of the evaluated function, in the order F, F1, C F2, F3, F11, F12, F22, F13, F23, F33. This parameter may C coincide with FINP, in which case FINP is destroyed on C output. Note that this coincidence is an exception to C ANSI standard of FORTRAN 77. C C No subroutines and external functions required. C C Date: 1999, January 15 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL F,AUX1,AUX2 C IF(POWER.EQ.0.) THEN DO 1 I=1,N FOUT(I)=0. 1 CONTINUE ELSE IF(0.999.LT.POWER.AND.POWER.LT.1.001) THEN DO 2 I=1,N FOUT(I)=FINP(I) 2 CONTINUE *V CALL VAR4(0,1.) ELSE IF(FINP(1).LT.0.) THEN C 317 CALL ERROR('317 in FPOWER: Negative material parameter') C Nonunit power of a material parameter is not allowed to be C negative. The negative value may be caused by oscillatory C character of interpolated positive values. ELSE IF(FINP(1).EQ.0.) THEN IF(POWER.LT.0.) THEN C 318 CALL ERROR('318 in FPOWER: Zero inverse material parameter') C Negative power of a material parameter cannot be zero. ELSE FOUT(1)=0. DO 3 I=2,N IF(FINP(I).NE.0.) THEN C 319 CALL ERROR('319 in FPOWER: Zero material parameter') C Nonunit power of zero material parameter is not allowed to C have nonzero derivatives. END IF FOUT(I)=0. 3 CONTINUE END IF ELSE IF(-1.001.LT.POWER.AND.POWER.LT.-0.999) THEN F=1./FINP(1) ELSE F=FINP(1)**(1./POWER) END IF FOUT(1)=F IF(N.GT.1) THEN AUX1= F/(FINP(1)*POWER) AUX2= (POWER-1.)/F FOUT(2)=AUX1*FINP(2) FOUT(3)=AUX1*FINP(3) FOUT(4)=AUX1*FINP(4) IF(N.GT.4) THEN FOUT(5)=AUX1*FINP(5)-AUX2*FOUT(2)*FOUT(2) FOUT(6)=AUX1*FINP(6)-AUX2*FOUT(2)*FOUT(3) FOUT(7)=AUX1*FINP(7)-AUX2*FOUT(3)*FOUT(3) FOUT(8)=AUX1*FINP(8)-AUX2*FOUT(2)*FOUT(4) FOUT(9)=AUX1*FINP(9)-AUX2*FOUT(3)*FOUT(4) FOUT(10)=AUX1*FINP(10)-AUX2*FOUT(4)*FOUT(4) END IF *V CALL VAR4(0,AUX1) *V CALL VAR4(2,-AUX2*FOUT(2)) *V CALL VAR4(3,-AUX2*FOUT(3)) *V CALL VAR4(4,-AUX2*FOUT(4)) END IF END IF RETURN END C C======================================================================= Cmodel.htm 0100666 0000765 0000765 00000056620 07473352304 012263 0 ustar bulant bulant
This is just a general overview, the detailed description of input data, procedures, and other important topics is included within the individual FORTRAN77 source code files.
Programming language, error messages, screen output, etc.
Alphabetical list of input parameters of all programs.
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 (since version
5.00) which should be more convenient than uppercase on Unix systems.
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:
The way of building the model is concisely described in the paper on C.R.T. The model building technique is independent of the coordinate system, independent of the method used to specify and interpolate the surfaces covering structural interfaces, and independent of the functions describing the distribution of material properties within the individual complex geological blocks.
The model is specified in terms of subroutines (e.g., subroutines to evaluate the values and partial derivatives of the functions describing surfaces or material parameters) and of the input data for the subroutines. Although both the subroutines and the data may be modified by a user, most of the users wish to modify only the input data, using the interpolation routines contained within the basic version of the MODEL package.
The basic subroutines to deal with general blocky geological structures are located within the source code file 'model.for'. Among them, the most important subroutine is BLOCK determining the relation of a given point with respect to geological blocks. The data describing the model topology are described within the source code file 'model.for'.
To specify a particular model, the following routines should be available:
To deal with the first order model variations for the purposes of inverse problems, the routines VAR1 to VAR5 should be called properly during the evaluation of functions describing surfaces or material properties in order to memorize the variations. The invocations of VAR1 to VAR5 are irrelevant for forward modelling. These invocations are denoted by '*V' in the first two columns of source code (files 'model.for', 'parm.for', 'val.for', and 'fit.for'). The source code lines with '*V' should be modified or removed by means of the program 'clean.for' or a text editor. When submitting different subroutines SRFC2 and PARM2 while dealing with inverse problems, the user is responsible for proper invocation of routines VAR1 to VAR5.
Description of input data to specify the model The data are read by the subroutine MODEL1 and are described in the FORTRAN77 source code file 'model.for'.
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
(denoted by * in Fortran code),
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.
The model specification software consists of package FORMS and of the following FORTRAN77 source code and demo files:
Notes:
Model specification routines (B) and (C) for forward modelling are
likely to be required by all applications.
Example: 'grid.for' program linked with all files of (B)
and (C).
In addition, some of service routines (E) are required by some
applications.
Example 1: 'sec.for' program linked with the files
'modsec.for', 'means.for', 'rkgs.for', and all files of
(B) and (C).
Example 2: complete ray tracing program and routines
linked with 'means.for', 'hpcg.for', and all files of
(B) and (C).
Inverse modelling programs are likely to require model
specification routines (B) and (C) for forward modelling
together with the model specification routines (D) for
inverse modelling. Do not forget to use the versions with
'*V' in the first two columns of source code replaced by a
pair of spaces.
C INCLUDE 'model.inc' C ------------------------------------------------------------------ CHARACTER*80 TEXTM COMMON/MODELT/TEXTM SAVE /MODELT/ C .................................................................. INTEGER MSB,MCB PARAMETER (MSB=128) PARAMETER (MCB=128) INTEGER NEXPV,NEXPQ,IVERT,NEGPAR REAL BOUNDM(6) INTEGER NSRFCS,NSB,KSB(0:MSB),NCB,KCB(0:MSB) EQUIVALENCE (KSB(0),NSB),(KCB(0),NCB) COMMON/MODELC/NEXPV,NEXPQ,IVERT,NEGPAR,BOUNDM,NSRFCS,KSB,KCB SAVE /MODELC/ C ------------------------------------------------------------------ C TEXTM...The name of the model. String of 80 characters. C C NEXPV,NEXPQ... Specify exponents of the power of velocities C (NEXPV) and Q-factors (NEXPQ) in input data. For example, C unit values of NEXPV and NEXPQ indicate that the C parameters of the medium are velocities and Q factors, C indices equal -1 indicate reciprocal values of these C quantities, i.e. slownesses and loss factors. C IVERT...Orientation of the vertical axis: C IVERT=0: unknown (default), C IVERT=+1: X1 vertical, pointing upwards, C IVERT=-1: X1 vertical, pointing downwards, C IVERT=+2: X2 vertical, pointing upwards, C IVERT=-2: X2 vertical, pointing downwards, C IVERT=+3: X3 vertical, pointing upwards, C IVERT=-3: X3 vertical, pointing downwards, C Should have no influence on the calculations. If it C is non-zero, it may be considered for plotting purposes. C NEGPAR..Flag whether the negative values of material parameters C are allowed: C NEGPAR=0: Negative values of material parameters or zero C P-wave velocity are reported as errors. C NEGPAR=1: Negative values of material parameters or zero C P-wave velocity are not reported as errors. C BOUNDM..Boundaries X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX of the C model. C NSRFCS..Number of smooth surfaces in the model. The surfaces C are indexed sequentially by positive integers, from 1 to C NSRFCS. NSRFCS is the storage location for NSRFC. C NSB... Number of material simple blocks in the model. The blocks C are indexed sequentially by positive integers ISB from 1 C to NSB. Free-space blocks are not indexed. C KSB... Contains the indices of the surfaces bounding individual C simple blocks. KSB(ISB), for ISB = 1 to NSB, specify the C partition of array KSB(NSB+1:NSB+NS) among the simple C blocks. Here NS is the total number of all occurences of C the indices of the surfaces bounding all individual simple C blocks in the input data. The indices of the surfaces C bounding individual simple blocks are stored from C KSB(NSB+1) to KSB(NSB+NS). The locations KSB(NSB+NS+1:MSB) C are undefined. It must be NSB+NS.LT.MSB. The indices of C the surfaces bounding the simple block ISB are stored in C KSB(I1) to KSB(I2), with C I1 = KSB(ISB-1)+1 , C I2 = KSB(ISB) , C where KSB(ISB-1)=NSB for ISB=1. For each simple block C with index ISB, the indices of the surfaces forming the C set F(+) are stored with positive signs, the indices of C surfaces from F(-) with negative signs. For an example C refer to the sample input data for the model. C NCB... Number of material complex blocks in the model. The blocks C are indexed sequentially by positive integers ICB from 1 C to NCB. The free-space blocks are not indexed. C KCB... Contains the indices of the simple blocks forming C individual complex blocks. KCB(ICB), for ICB = 1 to NCB, C specify the partition of array KSB(NCB+1:NCB+NB) among the C complex blocks. Here NB is the total number of all C occurences of the indices of the simple blocks forming C individual complex blocks in the input data. The indices C of the simple blocks forming individual complex blocks are C stored from KSB(NCB+1) to KSB(NCB+NB). The locations C KSB(NCB+NB+1:MCB) are undefined. It must be NCB+NB.LT.MCB. C The indices of the simple blocks forming complex block ICB C are stored in KCB(I1) to KCB(I2), where C I1 = KCB(ICB-1)+1 , C I2 = KCB(ICB) . C Here KCB(ICB-1)=NCB for ICB=1. For an example refer to C the sample input data for the model. C C All the input data are stored sequentially in the same order as C they were read. The only exception are locations KSB(1) to C KSB(NSB) and KCB(1) to KCB(NCB) which are inserted when the input C data are being read . The index of the last allocated numeric C storage unit of array KSB is named MSB. The index of the last C allocated numeric storage unit of array KCB is named MCB. The C values of MSB and MCB are given by the sixth and seventh statement C of the block data subroutine MODELB. If the value of MSB or MCB C is changed, it must be adjusted in all subroutines which include C the common block /MODELC/. C C Common block /MODELT/ is included in external procedure MODEL1. C of file 'model.for', and in subroutine SECT1 of file 'sec.for'. C C Common block /MODELC/ is included in external procedures MODEL1, C BLOCK, ISIDE, INTERF of file 'model.for', in subroutines FUNC and C DISC of file 'sec.for', in program 'intf.for', in subroutine C RAY1 of file 'ray.for' of package CRT, in 'bndlin.for', C and may be included in any other subroutine. C C Date: 1999, August 16 C Coded by Ludek Klimes C C======================================================================= Cmodelver.htm 0100666 0000765 0000765 00000045606 07474344574 013015 0 ustar bulant bulant
modelv.for 0100666 0000765 0000765 00000143232 07041770474 012446 0 ustar bulant bulant CReleased versions of package MODEL
1.00 (1988, June): Preliminary version, contains only subroutines for model specification. There are no complete ray tracing subroutines yet. 2.00 (1990, February): Common release with complete ray tracing routines. First consistent version of the ray tracing program. Complete ray tracing poorly debugged. 3.00 (1991, January): Common release with complete ray tracing routines. Principal errors removed from complete ray tracing. 'parm.for': Evaluation of S-wave quality factor corrected. 4.00 (1992, December): MODEL and CRT packages have been split: 'raycb.for' split into 'means.for' (MODEL) and 'raycb.for' (CRT). Subroutine FPOWER moved from 'val.for' to 'model.for'. 'val.for': Incorrect storage of function coefficients in common block /VALC/ fixed. New check for incorrect indices of the class or group during invocation of VAL2. Bugs in the evaluation of embedded functions fixed. 'val.for': Incorrectly coded linear extrapolation of functions outside the given spline grid replaced by analytic continuation. Linear version partially fixed and denoted with 'CV3' in the first three columns. 'val.for': Hermite representation of 1-D cubic splines replaced by a B-spline representation (CURVB1 and CURVB2 of 'fit.for' called instead of CURVN1 and CURV2D). 'model.for', 'srfc.for', 'parm.for', 'val.for', and 'fit.for': Minor corrections to conform with the FORTRAN77 standard. 'means.for': *** Considerable changes and corrections.*** *** new ***: 'model.for', 'parm.for', 'val.for', and 'fit.for': Invocations of VAR* routines enabling inversion have been added and denoted by 'V' in the first column. 'var.for', 'varnul.for', and 'spsp.for': New additional model specification subroutine files for inverse modelling. 'grid.for', 'modsec.for', 'sec.for', 'secdxf.for', and 'secacd.for': New sample application programs and routines working with the model, mostly for the purposes of model displaying. For the same reasons, subroutine CARTES has been added to 'metric.for'. 'clean.for': New simple program to enable a conditional compilation. 4.10 (1994, January): 'model.for', 'parm.for', 'val.for', 'var.for', 'varnul.for', 'means.for', 'grid.for', 'modsec.for', 'lindxf.for', 'clean.for': Error messages, previously generated by statements like STOP 'Error...', are now generated by PAUSE 'Error...' followed by the STOP statement, in order to suspend the batch files in the case of error (the date of subroutines not updated). 'model.for', 'metric.for', 'val.for', 'modsec.for': Each block data subprogram has been declared external in the subroutine designed to read or initialize the data shared. The subroutine is the first subroutine in the corresponding file, after the block data subprogram, and was always assumed to be called before the data in the corresponding common blocks can be used. 'spsp.for': External procedures declared external. 'modsec.for': Two severe bugs fixed (index of a simple block, section boundaries). 'model.for', 'means.for', 'grid.for', 'modsec.for', 'clean.for': Other minor fix-ups and improvements. *** new ***: 'forms.doc': General description of files containing Lines (lines at interfaces, velocity isolines, rays, etc.) or Points (gridded interfaces, sources, receivers, ray endpoints, etc.). The files are introduced especially to simplify data transfer and plotting. 'grid.for': Model specified in curvilinear coordinates is now gridded in Cartesian coordinates. 'array.for': New subroutines to write real arrays into disk files and to read them. Common with package 'NET'. 'modsec.for': New option of generating regularly spaced points along structural interfaces or velocity isolines. New format of output files is described in 'forms.doc'. Common specification of parallel profiles - a change in the input data for the profiles (obligatory slash). 'lindxf.for', 'linacd.for': Replaced 'secdxf.for' and 'secacd.for' to transform lines into the CAD or ACROSPIN format. 5.00 (1996, September): 'model.for', 'parm.for', 'val.for', and 'fit.for': Invocations of VAR* routines enabling inversion are denoted by '*V' instead of 'V ' in the first two columns. No need to patch the code before compilation henceforth. 'model.for': *** Change in input data for model *** (IVERT key added). Subroutine BLOCK slightly extended. 'metric.for': Subroutine CARTES corrected. 'val.for': *** Input grid values for interpolation may now correspond to any power of the interpolated quantity. Model data read by 'srfc.for' and 'parm.for' changed.*** Default keys defining the function form introduced. Number of model parameters increased to NPAR=100000. 'var.for': Number of registers and variations increased to MFUNCT=48 and MB=3072. 'means.for': *** Considerable changes and corrections.*** Unfortunately, not finished. 'grid.for': *** Change in input data, in generation of the partial derivatives, etc. *** 'array.for': Renamed to 'forms.for', updated, supplemented with subroutines FORM1 and FORM2. 'sec.for'+'modsec.for': Joined to single file 'sec.for'. Considerably updated. 'clean.for': Updated. 'mod.bat': *** Considerably changed.*** 'lindxf.for', 'linacd.for': Removed (moved to package D3). 'calcomp.for': Moved from package CRT. *** new ***: All files converted from UPPERCASE to both UpperCase and LowerCase (for better reading and Unix systems), INCLUDE statement introduced for COMMON blocks. '*.inc': Include files with COMMON blocks. SAVE statement is now used consistently for COMMON blocks All files with main programs supplemented with the INCLUDE statements to include all files with called subroutines to simplify the compilation and linking considerably. 'parm.for': Extended to anisotropic models with attenuation, maintaining all compatibility with the isotropic models. 'modelv.for','parmv.for','valv.for','fitv.for': Versions of 'model.for', 'parm.for', 'val.for', and 'fit.for' for inverse problems. 'length.for': Simple subroutine to determine the length of a string. 'gse.for': Subroutines to write and read seismograms in the GSE data exchange format. 'calcops.for': CalComp to PostScript graphics interface. 'modchk.for': Program to check the model consistency. 'intf.for': Program to check the positions of given points with respect to interfaces in the model. 'srp.for': Program to generate source and receiver points corresponding to given configuration parameters. 'pallet.for': Program to interpolate the RGB colour pallet linearly in the HSB colour space. 'sd','slit','wb','l7','mar': Subdirectories with examples of input data for seismic models. 5.10 (1997, October): *** probably not all changes are listed here *** 'forms.doc','length.for','forms.for','gse.for','srp.for', 'calcomp.for','calcomp.inc','calcops.for','calcops.inc', 'pallet.for','f': Moved to new package FORMS ('forms.doc' renamed to 'formsdoc.htm'). 'indexx.for': Moved to new package NR. 'soft.for','inv1soft.for','inv3.for','inv4.for','inv3.dat': Moved from package CRT. 'soft.for': *** Severe bug fixed. *** 'model.doc' renamed to 'modeldoc.htm'. 'lmod.bat' renamed to 'fmod.bat' and revised. 'gridnet.dat' renamed to 'grid.h' and changed into SEP. 'model.for','modelv.for','metric.for','sec.for': BLOCK DATA subprograms canceled. 'modchk.for','grid.for','inv1soft.for','inv3.for': Memory managed by means of 'ram.inc'. Descriptions corrected and updated in most files. All error descriptions moved towards the corresponding reporting statements. Errors renumbered in some files. *** new *** All Fortran files supplemented with HTML references. 'grid.for': Grid dimensions specified by SEP parameter file. 'len-grd.bat'... MS-DOS batch file to display 2-D velocity sections across the demo model 'model.dat'. 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('...'). 'modeldoc.htm' split into 'modeldoc.htm' and 'modelver.htm', list of files moved to 'model.htm'. 'parm.for': Bugs disabling anisotropic models fixed. New entry PARM4 determining whether a model is isotropic. 'modchk.for': Undefined free-space simple blocks now may or may not be reported. 'grid.for': *** Input data changed. *** 'grid.h': Updated. *** 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. 5.30 (1999, June): 'model.for': Fatal bug in subroutine FPOWER when calculating the power of a zero material parameter fixed. Subroutine BLOCK completely rewritten and its extended version BLOCKS added. Subroutine INTERF upgraded, new subroutine SEPAR supplemented. 'means.for', 'grid.for', 'sec.for': Updated to correspond to the new version of subroutines BLOCK and BLOCKS. 'val.for': Zero POWERW in input data now reported as error. 'model.dat', 'prem/prem-mod.dat', 'elf1/elf1-mod.dat', 'wb/wb2-mod.dat','l7/l7-mod.dat': Free space simple blocks added. *** new *** 'modsrf.for', 'modsrf.inc': Program to approximate structural interfaces and velocity sections by polygons. 'bndlin.for': Program to write edges of the model box. 'len-mod.h', 'elf1/elf1-mod.h', 'sd/sd1-mod.h', 'sd/sd2-mod.h', 'wb/wb2-mod.h', 'l7/l7-mod.h' and corresponding data '*/*-cam.dat' and '*/*-dli*.dat': History file to generate 3-D VRML97 representations of structural interfaces and velocity distribution in the respective models. '*/*-cam.dat' describe the corresponding initial positions of the camera and '*/*-dli.dat' the directional lights. 'wrl': Subdirectory with 3-D VRML97 representations of several 3-D models. 5.40 (2000, May): 'modchk.for', 'sec.for', 'intf.for': *** Input data changed to SEP format. *** 'grid.for': *** Input data changed. *** Multiple files from * device moved to the history file. 'model.htm': Considerably revised. 'modeldoc.htm' discarded (information moved to 'model.htm'). 'model.for', 'model.inc': Now reading parameter NEGPAR. 'parm.for': Check for negative material parameters may now be disabled by SEP parameter NEGPAR, see 'model.for'. 'val.for': Missing initialization of variable GROUP fixed. 'val.inc': Comments updated. 'soft.for': *** Different weights for different material parameters introduced. Incorrect ordering of independent variables (coordinates) fixed. Two additional severe bugs related to array indices in common block VALC fixed. *** 'modchk.for', 'sec.for', 'intf.for': Since 'model.for' is reading NEGPAR, 'sep.for' has been included. 'bndlin.for': Minor bugs fixed. 'modsrf.for': Input parameters COLUMNii, POWERii, IVALUEii extended by ii=01,02,...,06. New option COLUMNii='SRF' introduced. Some bugs fixed. 'grid.for': *** Discretization of all material parameters and of functions describing interfaces enabled. *** 'model.inc' included because of parameter NEGPAR. Grid may be specified in Cartesian or model coordinates. 'sec.for': Output format corrected. 'inv3.for' discarded (replaced by better program 'modmod.for'). 'inv4.for' discarded, because 'modmod.for' followed by 'grid.for' and 'grdcal.for' do a better job. 'gels.for': Moved to package FORMS. Subdirectories with the data for particular models moved to new package DATA. 'len-*.*' moved to subdirectory 'len' of package DATA. 'model.dat' renamed to 'len-mod.dat', 'grid.h' to 'len-grid.h', 'sec.dat' to 'len-sec.dat', 'sec-pts.dat' to 'len-secp.dat' and all moved to subdirectory 'len' of package DATA. 'soft.dat' replaced with 'sob11.dat'. 'grid.dat' and 'inv3.dat' deleted because are used no more. *** new *** 'inv1soft.for' renamed to 'invsoft.for' and considerably updated (different weights of Sobolev scalar products for surfaces and various material parameters, SEP format of main input data, output in the form of vectors and matrices for convenient processing). 'invpts.for: Program to calculate the derivatives of functions, describing interfaces or material parameters, with respect to the model B-spline coefficients. 'modmod.for': New program to modify the model (update or change parametrization). 'modle2d.for': Provisional version of the program to calculate directional Lyapunov exponents and average Lyapunov exponent for a 2-D model without interfaces. 'sob22.dat','sob22n.dat','sob22l.dat','sob33.dat', 'sob33n.dat','sob22l.dat': General specifications of isotropic Sobolev scalar products. 5.50 (2001, June): 'metric.for': *** Wrong Christoffel symbols in geographic spherical coordinates fixed. *** 'soft.for': Changed to treat surfaces and material parameters separately. 'modchk.for': Comments updated. 'modsrf.for': *** Functionality considerably improved: *** Identification of intersections of gridlegs with interfaces improved. Identification of intersections of gridfaces with edges on interfaces improved. New algorithm for creation of polygons from the identified intersection points coded. 'grid.for': *** Wrong gridding of oblique vertical sections fixed. *** Comments corrected. 'intf.for': Changed to enable writing of results to other than first four columns of the output file, and to enable preserving the values from input file. *** For special case KOLUMN=0 and KSRFC=0 input data changed to KOLUMN=-1 and KSRFC=0. *** 'invsoft.for': *** Wrong output values of model parameters fixed. Check of the dimension of array RAM improved. *** 'invsoft.for', 'invpts.for': *** New input parameter ICLASS, enabling to separate inversions of surfaces and material parameters. *** 'invsoft.for', 'invpts.for', 'modmod.for': *** Revised to understand new parameters FORMM, FORMMR and FORMMW, included to switch the form of the files with matrices between formatted and unformatted. *** 'modle2d.for': *** New parameter NY, enabling to perform calculations also in 3-D models. Models with free space enabled. *** Output format updated. 5.60 (2002, May): 'modsrf.for': Comments updated, minor change to decrease the error in the position of structural edges. 'modmod.for': *** Poor declaration of external function LENGTH fixed. ***
C Subroutine file 'model.for' to specify a seismic model. C C Date: 1999, December 6 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following external procedures: C MODEL1..Subroutine designed to read the input data for the C description of the model and to store them in the memory. C Subroutine MODEL1 reads the input data (1)-(8) listed C below itself, then calls subroutine SRFC1 (included in the C subroutine file 'srfc.for') to read the input data (9) for C smooth surfaces, and finally calls subroutine PARM1 C (included in the subroutine file 'parm.for') to read the C input data (10) for the parameters of the medium. C MODEL1 C NSRFC...Integer function returning the number of surfaces covering C structural interfaces. C NSRFC C BLOCK...Subroutine designed to determine the mutual position of a C point and a simple and a complex block. Just calls more C general subroutine BLOCKS which does the job. C BLOCK C BLOCKS..Subroutine designed to determine the mutual position of a C point and a simple and a complex block. A more general C version of subroutine BLOCK, designed especially to work C with curves situated at structural interfaces. C BLOCKS C ISIDE...Auxiliary function to subroutine BLOCKS. C ISIDE C INTERF..Auxiliary subroutine to subroutine BLOCKS. C INTERF C SEPAR...Subroutine determining the surface separating two given C simple blocks. C SEPAR C VELOC...Subroutine transforming the values of a medium parameters C into velocities and loss factors. C VELOC C FPOWER..Subroutine evaluating the value and, possibly, the three C first and six second partial derivatives of a function, C if the value and the three first and six second partial C derivatives of the POWER-th power of the function are C known. Particularly, this is an auxiliary subroutine C to the subroutine VELOC. C FPOWER C C Note: C The lines denoted by '*V' in the first two columns of file C 'model.for' in subroutines VELOC and FPOWER are designed to C calculate the model variations with respect to the model C parameters. C File 'modelv.for', intended for the model inversion, is created C from 'model.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C C....................................................................... C C C Input data MODEL for the specification of the model: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new READ statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise (except TEXTM), the input parameter is of the C type REAL. C (1) TEXTM C The string containing the name of the model. Only the first 80 C characters of the string are significant. C (2) KOORS,NEXPV,NEXPQ,IVERT,/ C KOORS...Specifies the type of the coordinate system: C KOORS.LE.0: Cartesian coordinates (default). C KOORS.EQ.1: polar spherical coordinates in radians, C (X1,X2,X3)=(colatitude,longitude,radius). C KOORS.GE.2: geographic spherical coordinates in radians, C (X1,X2,X3)=(longitude,latitude,radius). C If the coordinate system is right-handed (recommended), C all vectorial products are evaluated using the right-hand C rule, otherwise using the left-hand rule. C KOORS is passed to the subroutines of file 'metric.for' C by means of invocation of subroutine METR1 and presently C represents the only input data for the coordinate system. C Note that possible future additional data for the C coordinate system should be read by subroutine METR1 and C should be located between input data (2) and (3). C metric.for C NEXPV,NEXPQ... The default values are highly recommended! C Velocities powered to NEXPV and loss factors powered to C NEXPQ are reported by the subroutines evaluating isotropic C material parameters. C For example, unit values of NEXPV and NEXPQ indicate that C velocities and loss factors are the output parameters C of the subroutines evaluating isotropic material C parameters, indices equal -1 indicate reciprocal values of C these quantities, i.e. slownesses and quality factors. C When using the basic submitted version of the subroutine C file 'parm.for', the default values of NEXPV=1, NEXPQ=1 C are highly recommended. Other values make sense only if a C user is submitting his own subroutines to evaluate C isotropic material parameters which, e.g., output the C slowness instead of the velocity. In such a case, C switching NEXPV from 1 to -1 may avoid the modification C of the user's subroutines. C IVERT...Orientation of the vertical axis: C IVERT=0: unknown (default), C IVERT=+1: X1 vertical, pointing upwards, C IVERT=-1: X1 vertical, pointing downwards, C IVERT=+2: X2 vertical, pointing upwards, C IVERT=-2: X2 vertical, pointing downwards, C IVERT=+3: X3 vertical, pointing upwards, C IVERT=-3: X3 vertical, pointing downwards, C Has no influence on the calculations, and need not be C specified. If it is non-zero, it may be considered for C plotting purposes. C /... Obligatory slash at the end of line for future extensions. C Default: KOORS=0, NEXPV=1, NEXPQ=1, IVERT=0. C (3) X1MIN,X1MAX,X2MIN,X2MAX,X3MIN,X3MAX C Boundaries of the model. C (4) NSRFC C Number of smooth surfaces in the model. The surfaces are indexed C sequentially in any order by positive integers ISRFC from 1 to C NSRFC. C It is recommended to define only surfaces covering structural C interfaces (model surfaces) in this data set. Auxiliary surfaces C related to particular source-receiver configurations, numerical C procedures, etc., should preferably be defined in other data sets. C (5) NSB C Number of simple blocks in the model, defined in this data set. C The defined blocks are indexed sequentially by positive integers C ISB from 1 to NSB in the same order as they are specified in data C (6). Intersecting simple blocks are allowed but not recommended. C All material simple blocks in the model must be defined. C Free-space blocks need not be defined in this data set but it is C recommended to define the free-space simple blocks in order to C speed up the determination of a free space during computations. C Defined free-space blocks also enhance the possibility to check C for the model consistency. If the free-space simple blocks are C not, for some reason, defined here, they may be defined in the C additional data file designed just for the consistency check by C program modchk.for C (6) NSB input operations (READ statements): C For each simple block with index ISB, the indices of the surfaces C forming the set F(+) and the indices of the surfaces forming the C set F(-). The indices of surfaces from F(+) must be positive, the C indices of surfaces from F(-) must be indicated by negative signs. C The indices may be specified in an arbitrary order and must be C terminated by a slash. C (7) NCB C Number of material complex blocks in the model. The material C complex blocks are indexed sequentially by positive integers ICB C from 1 to NCB. The free-space complex block is not indexed and C consists of all simple blocks not contained in the material C complex blocks. Space covered by no simple block is also deemed C to be a free space. C (8) NCB input operations (READ statements): C For each material complex block, the indices of material simple C blocks forming the complex block. The indices may be specified C in an arbitrary order and must be terminated by a slash. C Each material simple block must appear exactly once within these C data lines. Simple blocks defined by data (6) but not listed here C are deemed to be free-space simple blocks. C (9) The data specifying NSRFC functions F(X1,X2,X3) describing the C smooth surfaces in the model. The data are read by subroutine C SRFC1. For their description refer to subroutine SRFC1 (included C in the subroutine file 'srfc.for'). C srfc.for: Input data C (10) The data specifying the distribution of parameters of the model C in all NCB material complex blocks. The data are read by C subroutine PARM1. For their description refer to subroutine C PARM1 (included in the subroutine file 'parm.for'). C parm.for: Input data C For an example refer to the sample input data for the model. C Example of data set MODEL C C C Input data in the form of SEP C parameter or history file: C NEGPAR=integer... Flag whether the negative values of material C parameters are allowed: C NEGPAR=0: Negative values of material parameters or zero C P-wave velocity are reported as errors. C NEGPAR=1: Negative values of material parameters or zero C P-wave velocity are not reported as errors. C Default: NEGPAR=0 C C....................................................................... C C Storage in the memory: C The input data (1) to (8) describing the structure of the model C are stored in common blocks /MODELT/ and /MODELC/ defined in the C include file 'model.inc'. C model.inc C C======================================================================= C C C SUBROUTINE MODEL1(LUN) INTEGER LUN C C Subroutine MODEL1 reads the input data (1)-(8) for the description C of the model and stores them in common blocks /MODELT/ and /MODELC/. C Then it calls subroutine SRFC1 (included in the subroutine file C 'srfc.for') to read the input data (9) for smooth surfaces and to C store them in the memory. Finally, it calls subroutine PARM1 C (included in the subroutine file 'parm.for') to read the input data C (10) for the parameters of the medium and to store them in the memory. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C The input parameter is not altered. C C No output. C C Common blocks /MODELT/ and /MODELC/: INCLUDE 'model.inc' C model.inc C All the storage locations of the common blocks are defined in this C subroutine. C C Subroutines and external functions required: EXTERNAL RSEP3I,METR1,SRFC1,PARM1 C RSEP3I...File 'sep.for'. C METR1...File 'metric.for'. C SRFC1 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C PARM1 and subsequent routines... File 'parm.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1999, August 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I,J,L C READ(LUN,*) TEXTM I=0 NEXPV=1 NEXPQ=1 IVERT=0 READ(LUN,*) I,NEXPV,NEXPQ,IVERT CALL METR1(I) READ(LUN,*) BOUNDM READ(LUN,*) NSRFCS C C Simple blocks: C Number of simple blocks READ(LUN,*) NSB C Initializing memory for indices of surfaces bounding simple blocks L=NSB+1 DO 11 I=L,MSB KSB(I)=0 11 CONTINUE C Reading indices of surfaces bounding simple blocks: DO 14 J=1,NSB READ(LUN,*) (KSB(I),I=L,MSB) DO 12 I=L,MSB IF(IABS(KSB(I)).GT.NSRFCS) THEN C 311 CALL ERROR('311 in MODEL: Block bounded by wrong interface') C Index of the surface bounding the simple block is greater C than the specified number of surfaces. ELSE IF(KSB(I).EQ.0) THEN KSB(J)=I-1 L=I GO TO 13 END IF 12 CONTINUE GO TO 99 13 CONTINUE 14 CONTINUE C C Complex blocks: C Number of complex blocks READ(LUN,*) NCB C Initializing memory for indices of simple blocks forming c. blocks L=NCB+1 DO 21 I=L,MCB KCB(I)=0 21 CONTINUE C Reading indices of simple blocks forming complex blocks DO 24 J=1,NCB READ(LUN,*) (KCB(I),I=L,MCB) DO 22 I=L,MCB IF(KCB(I).LT.0.OR.KCB(I).GT.NSB) THEN C 312 CALL ERROR * ('312 in MODEL: C. block composed of wrong s. block.') C Complex block composed of wrong simple block: C Index of a simple block composing the complex block is C greater than the specified number of simple blocks. ELSE IF(KCB(I).EQ.0) THEN KCB(J)=I-1 L=I GO TO 23 END IF 22 CONTINUE GO TO 99 23 CONTINUE 24 CONTINUE C C Smooth surfaces: CALL SRFC1(LUN,NSRFCS) C C Material parameters: CALL PARM1(LUN,NCB) CALL RSEP3I('NEGPAR',NEGPAR,0) RETURN C 99 CONTINUE C 310 CALL ERROR('310 in MODEL1: Insufficient memory in /MODELC/') C Insufficient memory for the input data in common block /MODELC/. C The dimensions MSB or MCB of arrays KSB or KCB, respectively, C must be enlarged. C Refer to include file model.inc END C C======================================================================= C C C INTEGER FUNCTION NSRFC() C C Integer function NSRFC is designed to return the number of surfaces C covering structural interfaces. C C No input. C C Output: C NSRFC...Number of surfaces covering structural interfaces. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1989, December 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C No auxiliary storage locations. C NSRFC=NSRFCS RETURN END C C======================================================================= C C C SUBROUTINE BLOCK(COOR,ISRF1,ISB1,ISRF2,ISB2,ICB2) REAL COOR(3) INTEGER ISRF1,ISB1,ISB2,ICB2,ISRF2 C C This subroutine searches for the simple block and the complex block in C which a given point is situated. This routine may be also used to C determine the index of a block touching a specified block at a given C point situated on the boundary of the specified block (the situation C which may occur when a ray impinges on a boundary of a block). C Another function of the routine is to determine the index of the C surface bounding a given simple block and separating it from the given C point. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C ISRF1...Controls the possible determination of the simple block C touching block ISB1 at the given point. C ISRF1.EQ.0: The simple block touching ISB1 at the given C point need not be determined. This is the most frequent C option, used, e.g., if the given point is not situated C at a structural interface or if the simple block C touching ISB1 is already known. C ISRF1.NE.0: Index of the surface at which the given point C is situated and which separates simple block ISB1 from C another block to be determined and returned in ISB2. C Since the given point may be situated on either side of C the surface, surface IABS(ISRF1) is skipped in the list C of surfaces limiting simple blocks when determining the C position of the given point with respect to simple C blocks. The sign of ISRF1 is ignored. C This option cannot be used together with ISB1.EQ.0. C ISB1... Index of the simple block which position with respect to C the given point will be checked. C ISB1.EQ.0: No simple block given. The simple block in C which the given point is situated will be determined C and returned in ISB2. ISRF2 will be set to zero. C The determination starts with initial estimate ISBOLD, C continuing with ISBOLD+1, ISBOLD-1, ISBOLD+2, ISBOLD-2, C etc. Here ISBOLD is the simple block returned in ISB2 C during the last invocation of this subroutine with C ISB1.EQ.0 on input and ISB2.NE.0 on output. ISBOLD=1 C before such an invocation. C ISB1.GT.0: The position of the given point with C respect to simple block ISB1 will be examined. C If the point is situated in ISB1, the output value C of ISRF2 is set to 0. C If the point is situated in ISB1 and ISRF1.EQ.0, C the output value of ISB2 is set to ISB1. C If the point is situated in ISB1 and ISRF1.NE.0, C the simple block containing the given point, C separated from block ISB1 by surface ISRF1 and not C separated from block ISB1 by another surface will be C determined and returned in ISB2. C If the point is not situated in ISB1, the surface C separating the point from ISB1 is output in ISRF2. C In addition, the simple block containing the given C point, separated from block ISB1 by surface ISRF2 and C not separated from block ISB1 by another surface will C be determined and returned in ISB2. C The determination starts with initial estimate ISB1, C continuing with ISB1+1, ISB1-1, ISB1+2, ISB1-2, etc. C None of the input parameters are altered. C C Output: C ISRF2...For the given point not situated inside block ISB1 or C at its boundary, ISRF2 has the meaning of the index of C one of the surfaces bounding simple block ISB1 and C separating the given point from simple block ISB1, C supplemented by a sign '+' or '-' for the simple block C ISB1 situated at the positive or negative side of the C surface, respectively. If the point is separated from C simple block ISB1 by several surfaces, the first one of C the surfaces, for which ISB2 (see description of ISB2 C below) will be positive, is preferred. Roughly speaking, C surface ISRF2 at which simple block ISB1 touches simple C block containing the given point is preferred. C ISRF2=0 if ISB1=0 or if the given point is situated inside C block ISB1 or at its boundary. C If ISRF1.NE.0, the position with respect to surface C IABS(ISRF1) is not checked. C ISB2... Index of the simple block containing the given point. C If ISB1.EQ.0: C ISB2 is the index of the simple block containing the C given point. C The first simple block of ISBOLD, ISBOLD+1, ISBOLD-1, C ISBOLD+2, ISBOLD-2, etc., containing the given point, C is returned in ISB2. Here ISBOLD is the simple block C returned in ISB2 during the previous invocation of this C subroutine with ISB1.EQ.0. ISBOLD=1 during such the C first invocation. C If ISB1.NE.0: C If ISRF1.EQ.0 and ISRF2.EQ.0, ISB2 must not be C separated from simple block ISB1 by any surface. C A surface "separates" two simple blocks if both blocks C are bounded by the surface and are situated at its C opposite sides. C If ISRF1.NE.0 and ISRF2.EQ.0, ISB2 must be separated C from simple block ISB1 by surface IABS(ISRF1) and C must not be separated by another surface. C If ISRF2.NE.0, ISB2 must be separated from simple block C ISB1 by surface ISRF2 and must not be separated by C another surface. C The first simple block of ISB1, ISB1+1, ISB1-1, C ISB1+2, ISB1-2, etc., having the above properties, is C returned in ISB2. C If there is no simple block of the above properties, C ISB2=0. C ICB2... Index of the complex block in which simple block ISB2 is C situated. ICB2=0 if ISB2=0 or if simple block ISB2 is not C situated in any material complex block. C C Examples: C For each point of a set of discrete points, we wish to determine C simple block ISB and complex block ICB in which the point C is situated. C (a) We thus use C CALL BLOCK(COOR,0,0,I,ISB,ICB) C When tracing a curve (e.g., a ray), we wish rather to find each C crossed interface than only to determine the simple blocks C at discrete points along the curve. C (b) If the previous point along the curve is situated in C simple block ISB, we use C CALL BLOCK(COOR,0,ISB,ISRF1,ISBNEW,ICBNEW) C and get ISRF1.EQ.0 if no surface limiting simple block ISB C has been crossed. C (c) If ISRF1.NE.0, IABS(ISRF1) is the surface which has been C crossed. We should determine the point of intersection of C the curve with surface IABS(ISRF1). Then we use C CALL BLOCK(COOR,ISRF1,ISB,ISRF2,ISB2,ICB2) C to find simple block ISB2 and complex block ICB2 at the C other side of surface ISRF1. If ISRF2.EQ.0, the blocks C are successfully determined. If ISRF2.NE.0, surface C IABS(ISRF2) has also been crossed and we have to repeat C step (c) with ISRF1=ISRF2. C When tracing a curve along surface ISRFA, we call subroutine C BLOCKS instead of BLOCK, with analogous arguments: C (b') ISRF(1)=0 C ISRF(2)=ISRFA C CALL BLOCKS(COOR,2,ISRF,ISB,ISRF1,ISBNEW,ICBNEW) C (c') ISRF(1)=ISRF1 C ISRF(2)=ISRFA C CALL BLOCKS(COOR,2,ISRF,ISB,ISRF2,ISB2,ICB2) C Analogously, when tracing the curve of intersection of surfaces C ISRFA and ISRFB, we call subroutine BLOCKS in the C following way: C (b") ISRF(1)=0 C ISRF(2)=ISRFA C ISRF(3)=ISRFB C CALL BLOCKS(COOR,3,ISRF,ISB,ISRF1,ISBNEW,ICBNEW) C (c") ISRF(1)=ISRF1 C ISRF(2)=ISRFA C ISRF(3)=ISRFB C CALL BLOCKS(COOR,3,ISRF,ISB,ISRF2,ISB2,ICB2) C C Subroutines and external functions required: EXTERNAL BLOCKS C BLOCKS... This file. C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C INTEGER ISRF(1) C ISRF(1)=ISRF1 CALL BLOCKS(COOR,1,ISRF,ISB1,ISRF2,ISB2,ICB2) RETURN END C C======================================================================= C C C SUBROUTINE BLOCKS(COOR,NSRF1,ISRF,ISB1,ISRF2,ISB2,ICB2) REAL COOR(3) INTEGER NSRF1,ISRF(NSRF1),ISB1,ISRF2,ISB2,ICB2 C C This subroutine is a generalization of subroutine BLOCK to follow C points along structural interfaces and edges. Subroutine BLOCKS C searches for the simple block and the complex block in which a given C point is situated. The given point may be situated in the vicinity C of one or more structural interfaces. In such case, blocks at the C proper side of the interface(s) will be searched for. This routine C may also be used to determine the index of a block touching a C specified block at a given point situated on the boundary of the C specified block (the situation which may occur when a ray impinges on C a boundary of a block). Another function of the routine is to C determine the index of the surface bounding a given simple block and C separating it from the given point. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C NSRF1...Number of surface indices specified in array ISRF. C There must be NSRF1.GE.1. For ISB1.EQ.0., there must be C NSRF1.EQ.1 and ISRF(1).EQ.0. C ISRF... Array containing the indices of the surfaces at which the C given point is situated. Since the given point may be C situated on either side of the surfaces, the surfaces C listed in array ISRF are skipped in the list of surfaces C limiting simple blocks when determining the position of C the given point with respect to simple blocks. C The signs of the indices in array ISRF are ignored. C ISRF(1): Controls the possible determination of the C simple block touching block ISB1 at the given point. C ISRF(1).EQ.0: The simple block touching ISB1 at the C given point need not be determined. This is the most C frequent option, used, e.g., if the given point is not C situated at a structural interface or if the simple C block touching ISB1 is already known. C ISRF(1).NE.0: Index of the surface at which the given C point is situated and which separates simple block C ISB1 from another block to be determined. Refer to C the description of output parameter ISB2. C This option cannot be used together with ISB1.EQ.0. C ISRF(2) to ISRF(NSRF1): Indices of the surfaces at C which the given point is situated, other than ISRF(1). C These indices are designed to specify the surface along C which a curve is traced, or the surfaces which curve of C intersection is traced. C ISB1... Index of the simple block which position with respect to C the given point will be checked. C ISB1.EQ.0: No simple block given. The simple block in C which the given point is situated will be determined C and returned in ISB2. ISRF2 will be set to zero. C The determination starts with initial estimate ISBOLD, C continuing with ISBOLD+1, ISBOLD-1, ISBOLD+2, ISBOLD-2, C etc. Here ISBOLD is the simple block returned in ISB2 C during the last invocation of this subroutine with C ISB1.EQ.0 and ISB2.NE.0. ISBOLD=1 before such an C invocation. C ISB1.GT.0: The position of the given point with C respect to simple block ISB1 will be examined. C If the point is situated in ISB1, the output value C of ISRF2 is set to 0. C If the point is situated in ISB1 and ISRF(1).EQ.0, C the output value of ISB2 is set to ISB1. C If the point is situated in ISB1 and ISRF(1).NE.0, C the simple block containing the given point, C separated from block ISB1 by surface ISRF(1) and not C separated from block ISB1 by another surface will be C determined and returned in ISB2. C If the point is not situated in ISB1, the surface C separating the point from ISB1 is output in ISRF2. C In addition, the simple block containing the given C point, separated from block ISB1 by surface ISRF2 and C not separated from block ISB1 by another surface will C be determined and returned in ISB2. C The determination starts with initial estimate ISB1, C continuing with ISB1+1, ISB1-1, ISB1+2, ISB1-2, etc. C None of the input parameters are altered. C C Output: C ISRF2...For the given point not situated inside block ISB1 or C at its boundary, ISRF2 has the meaning of the index of C one of the surfaces bounding simple block ISB1 and C separating the given point from simple block ISB1, C supplemented by a sign '+' or '-' for the simple block C ISB1 situated at the positive or negative side of the C surface, respectively. If the point is separated from C simple block ISB1 by several surfaces, the first one with C positive ISB2 (see below) is preferred. C ISRF2=0 if ISB1=0 or if the given point is situated inside C block ISB1 or at its boundary. C Note that surfaces ISRF(1) to ISRF(NSRF1) are skipped C when determining the position of the given point with C respect to simple blocks. C ISB2... Index of the simple block containing the given point. C If ISB1.EQ.0: C ISB2 is the index of the simple block containing the C given point. C The first simple block of ISBOLD, ISBOLD+1, ISBOLD-1, C ISBOLD+2, ISBOLD-2, etc., containing the given point, C is returned in ISB2. Here ISBOLD is the simple block C returned in ISB2 during the previous invocation of this C subroutine with ISB1.EQ.0. ISBOLD=1 during such the C first invocation. C If ISB1.NE.0: C If ISRF(1).EQ.0 and ISRF2.EQ.0, ISB2 must not be C separated from simple block ISB1 by any surface. C A surface "separates" two simple blocks if both blocks C are bounded by the surface and are situated at its C opposite sides. C If ISRF(1).NE.0 and ISRF2.EQ.0, ISB2 must be separated C from simple block ISB1 by surface IABS(ISRF(1)) and C must not be separated by another surface. C If ISRF2.NE.0, ISB2 must be separated from simple block C ISB1 by surface ISRF2 and must not be separated by C another surface. C The first simple block of ISB1, ISB1+1, ISB1-1, C ISB1+2, ISB1-2, etc., having the above properties, is C returned in ISB2. C If there is no simple block of the above properties, C ISB2=0. C ICB2... Index of the complex block in which simple block ISB2 is C situated. ICB2=0 if ISB2=0 or if simple block ISB2 is not C situated in any material complex block. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL ISIDE,INTERF,SRFC2 INTEGER ISIDE C ISIDE,INTERF... This file. C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER MSEPAR PARAMETER (MSEPAR=20) INTEGER NSEPAR,KSEPAR(MSEPAR),JSEPAR,ISEPAR,ISIDE1,I,J,K,II(1) INTEGER ISBOLD,ISB0,ISRF1 SAVE ISBOLD DATA ISBOLD/1/ C C....................................................................... C ISRF1=ISRF(1) C C Checking input values: IF(ISRF1.LT.-NSRFCS.OR.ISRF1.GT.NSRFCS) THEN C 313 CALL ERROR('313 in BLOCK: Wrong index of surface') C Absolute value of the input parameter ISRFC1 (index of the C surface) is greater than the number NSRFC of the surfaces C covering structural interfaces. END IF IF(ISB1.LT.0.OR.ISB1.GT.NSB) THEN C 314 CALL ERROR('314 in BLOCK: Wrong index of simple block') C Parameter ISB1 (index of the simple block) is either C negative or greater than the number NSB of simple blocks. END IF IF(ISB1.EQ.0) THEN IF(NSRF1.NE.1.OR.ISRF1.NE.0) THEN C 315 CALL ERROR('315 in BLOCK: No simple block specified') C If no simple block ISB1 is specified, NSRF1 must be 1 and C ISRF1=ISRF(1) must be 0. END IF END IF C C Initial simple block ISB0: IF(ISB1.EQ.0) THEN ISB0=ISBOLD ELSE ISB0=ISB1 END IF C C Position of the given point with respect to simple block ISB0: ISRF2=0 CALL INTERF(COOR,NSRF1,ISRF,ISB0,MSEPAR,NSEPAR,KSEPAR) IF(NSEPAR.EQ.0) THEN C The point is inside simple block ISB0: IF(ISRF1.EQ.0) THEN ISB2=ISB0 GO TO 90 ELSE NSEPAR=1 KSEPAR(1)=ISRF1 END IF ELSE IF(ISB1.EQ.0) THEN NSEPAR=1 ELSE ISRF2=KSEPAR(1) END IF END IF C C Search for the simple block in which the given point is situated: DO 20 JSEPAR=1,NSEPAR IF(ISB1.NE.0) THEN ISEPAR=IABS(KSEPAR(JSEPAR)) ISIDE1=-ISIDE(ISEPAR,ISB1) END IF C Loop over simple blocks DO 19 J=1,MAX0(ISB0-1,NSB-ISB0) DO 18 ISB2=ISB0+J,ISB0-J,-2*J IF(ISB2.GT.0.AND.ISB2.LE.NSB) THEN C Selecting simple block ISB2 according to ISB1 IF(ISB1.NE.0) THEN C Loop for surfaces bounding block ISB1 DO 11 I=KSB(ISB1-1)+1,KSB(ISB1) C Skipping simple blocks separated from ISB1 by another C surface than ISEPAR K=KSB(I) IF(IABS(K).NE.ISEPAR) THEN IF(ISIDE(K,ISB1).EQ.-ISIDE(K,ISB2)) THEN GO TO 17 END IF END IF 11 CONTINUE C Skipping simple blocks not separated from ISB1 by ISEPAR IF(ISIDE(ISEPAR,ISB2).NE.ISIDE1) THEN GO TO 17 END IF END IF C Determining the position of the given point with respect C to the simple block CALL INTERF(COOR,NSRF1,ISRF,ISB2,1,I,II) IF(I.EQ.0) THEN IF(ISB1.EQ.0) THEN ISBOLD=ISB2 ELSE ISRF2=KSEPAR(JSEPAR) END IF GO TO 90 END IF 17 CONTINUE END IF 18 CONTINUE 19 CONTINUE 20 CONTINUE C No simple block has been found: ISB2=0 ICB2=0 RETURN C C Determination of the complex block: 90 CONTINUE DO 92 J=1,NCB DO 91 I=KCB(J-1)+1,KCB(J) IF(KCB(I).EQ.ISB2) THEN ICB2=J RETURN END IF 91 CONTINUE 92 CONTINUE C No complex block: ICB2=0 RETURN END C C======================================================================= C C C INTEGER FUNCTION ISIDE(ISRF,ISB) INTEGER ISRF,ISB C C This is an auxiliary function to the subroutine BLOCKS. C This function determines the mutual position of a surface and a simple C block. C C Input: C ISRF... Index of the surface. The sign is ignored. C ISB... Index of the simple block. C None of the input parameters are altered. C C Output: C ISIDE...ISIDE=-1: The simple block is bounded by the surface and C is situated on its negative side. C ISIDE= 1: The simple block is bounded by the surface and C is situated on its positive side. C ISIDE= 2: The simple block is not bounded by the surface. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1989, December 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER IS,LS,MS C LS=KSB(ISB-1)+1 MS=KSB(ISB) C C Loop for surfaces bounding simple block ISB: DO 1 IS=LS,MS IF(IABS(KSB(IS)).EQ.IABS(ISRF)) THEN ISIDE=ISIGN(1,KSB(IS)) RETURN END IF 1 CONTINUE C ISIDE=2 RETURN END C C======================================================================= C C C SUBROUTINE INTERF(COOR,NSRF1,ISRF1,ISB,MSRF2,NSRF2,ISRF2) REAL COOR(3) INTEGER NSRF1,ISRF1(NSRF1),ISB,MSRF2,NSRF2,ISRF2(MSRF2) C C This is an auxiliary subroutine to the subroutine BLOCKS. C This subroutine determines the position of a given point with respect C to a given simple block. C C Input: C COOR... Array containing coordinates X1, X2, X3 of a given point. C NSRF1...Number of surface indices specified in array ISRF1. C Must be NSRF1.GE.1. C ISRF1...Array containing the indices of the surfaces at which the C given point is situated. Since the given point may be C situated on either side of the surfaces, the surfaces C listed in array ISRF1 are skipped in the list of surfaces C limiting the simple block when determining the position of C the given point with respect to the simple block. C The signs of the indices in array ISRF1 are ignored. C Zero indices are allowed and have no neaning. C ISB... Index of the given simple block. C MSRF2...Dimension of array ISRF2. C None of the input parameters are altered. C C Output: C NSRF2...Number of surfaces separating the given point from simple C block ISB. C NSRF2=0 if the given point is situated inside simple C block ISB. C ISRF2...Indices of surfaces separating the given point from simple C block ISB, supplemented by sign '+' or '-' for simple C block ISB situated at the positive or negative side of the C surface, respectively. C The first MSRF2 such surfaces from the list of surfaces C limiting the simple block are reported. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL SRFC2 C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER IS,JS,KS,I REAL F(10) C F... Auxiliary array to contain the value and partial C derivatives F, F1, F3, F11, F12, F22, F13, F23, F33 of the C function describing surfaces at the given point. C C Speed-up storage locations: INTEGER MOLD PARAMETER (MOLD=20) INTEGER NOLD,IOLD(MOLD) REAL COLD(3) SAVE COLD,NOLD,IOLD DATA COLD/3*-999999./ C C....................................................................... C C Already examined surfaces: IF(COOR(1).NE.COLD(1).OR. * COOR(2).NE.COLD(2).OR.COOR(3).NE.COLD(3)) THEN NOLD=0 END IF C C Loop for surfaces bounding simple block ISB: NSRF2=0 DO 9 IS=KSB(ISB-1)+1,KSB(ISB) KS=KSB(IS) JS=IABS(KS) C Skipping surfaces of array ISRF1 DO 1 I=1,NSRF1 IF(JS.EQ.IABS(ISRF1(I))) THEN GO TO 8 END IF 1 CONTINUE C Surfaces already examined DO 2 I=1,NOLD IF(JS.EQ.IABS(IOLD(I))) THEN IF(IOLD(I)*KS.LT.0) THEN NSRF2=NSRF2+1 ISRF2(NSRF2)=KS IF(NSRF2.GE.MSRF2) THEN RETURN END IF END IF GO TO 8 END IF 2 CONTINUE C The surface has to be examined CALL SRFC2(JS,COOR,F) IF(NOLD.LT.MOLD) THEN IF(F(1).LT.0.) THEN NOLD=NOLD+1 IOLD(NOLD)=-JS ELSE IF(F(1).GT.0.) THEN NOLD=NOLD+1 IOLD(NOLD)= JS END IF END IF IF(F(1)*FLOAT(KS).LT.0.) THEN NSRF2=NSRF2+1 ISRF2(NSRF2)=KS IF(NSRF2.GE.MSRF2) THEN RETURN END IF END IF 8 CONTINUE 9 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE SEPAR(ISB1,ISB2,NSRF,ISRF) INTEGER ISB1,ISB2,NSRF,ISRF C C Subroutine determining the surface separating given simple blocks, C i.e., the surface limiting the simple blocks, which are situated one C at the positive side of the surface and the other at the negative side C of the surface. C C Input: C ISB1,ISB2... Indices of given simple blocks. C None of the input parameters are altered. C C Output: C NSRF... Number of surfaces separating the simple blocks. C ISRF... Index of a surface separating the simple blocks, C supplemented by sign minus if simple block ISB1 is C situated at its negative side. C If NSRF.EQ.0: ISRF contains unchanged input value. C If NSRF.GT.1: ISRF is one of the surfaces separating the C simple blocks. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C No subroutines and external functions required. C C Date: 1999, May 18 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I1,I2,KSBI2 C NSRF=0 C C Loop for surfaces bounding simple block ISB2 DO 2 I2=KSB(ISB2-1)+1,KSB(ISB2) KSBI2=-KSB(I2) C Loop for surfaces bounding simple block ISB1 DO 1 I1=KSB(ISB1-1)+1,KSB(ISB1) IF(KSB(I1).EQ.KSBI2) THEN NSRF=NSRF+1 IF(NSRF.EQ.1) THEN ISRF=KSB(I1) END IF END IF 1 CONTINUE 2 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE VELOC(IWAVE,UP,US,QP,QS,VP,VS,VD,QL) INTEGER IWAVE REAL UP(10),US(10),QP,QS,VP,VS,VD(10),QL C C This subroutine transforms the values of parameters of the medium into C velocities and loss factors. C C Input: C IWAVE...Type of wave. C IWAVE.GE.0: P wave, C IWAVE.LT.0: S wave. C UP,US...Powers of P and S wave velocities and their first and C second partial derivatives (the exponent of the powers is C NEXPV, see 'Input data for the model'), in order U, U1, C U2, U3, U11, U12, U22, U13, U23, U33. C QP,QS...Powers of the loss factors of P and S waves (the exponent C of the powers is NEXPQ, see 'Input data for the model'). C None of the input parameters are altered. C C Output: C VP,VS...P and S wave velocities. C VD... Velocity and its first and second partial derivatives C ordered as UP, US, corresponding to the wave specified by C IWAVE, in order V, V1, V2, V3, V11, V12, V22, V13, V23, C V33. C QL... Loss factor corresponding to the wave specified by IWAVE. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL FPOWER C FPOWER...This file. C C Date: 1992, December 31 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage location: REAL POWER,AUX1(1),AUX2(1) C POWER=FLOAT(NEXPV) IF(IWAVE.GE.0) THEN CALL FPOWER(10,UP,POWER,VD) CALL VAR5(1,1) VP=VD(1) CALL FPOWER(1,US,POWER,AUX2) VS=AUX2(1) AUX1(1)=QP ELSE CALL FPOWER(1,UP,POWER,AUX2) VP=AUX2(1) CALL FPOWER(10,US,POWER,VD) CALL VAR5(2,2) VS=VD(1) AUX1(1)=QS END IF CALL FPOWER(1,AUX1,FLOAT(NEXPQ),AUX2) QL=AUX2(1) RETURN END C C======================================================================= C C C SUBROUTINE FPOWER(N,FINP,POWER,FOUT) INTEGER N REAL FINP(N),POWER,FOUT(N) C C This subroutine evaluates the value and, possibly, the three first and C six second partial derivatives of a function if the value and the C three first and six second partial derivatives of the POWER-th power C of the function are known. C C Input: C N... For N=1: only the function value is evaluated. The C derivatives are ignored. C For N=4: the value and the three first partial derivatives C are evaluated. C For N=10: the value and the three first and six second C partial derivatives are evaluated. C FINP... Array containing the value, the first and second partial C derivatives of the POWER-th power of the function to be C evaluated, in the order F, F1, F2, F3, F11, F12, F22, F13, C F23, F33. For N=1, only the function value is required. C POWER...The specified function is equal to the POWER-th power of C the corresponding physical quantity. C POWER=0: Zero output array FOUT is generated. C None of the input parameters are altered (except FINP if this C parameter and FOUT are identical in the calling sequence). C C Output: C FOUT... Array containing the value, the first and second partial C derivatives of the evaluated function, in the order F, F1, C F2, F3, F11, F12, F22, F13, F23, F33. This parameter may C coincide with FINP, in which case FINP is destroyed on C output. Note that this coincidence is an exception to C ANSI standard of FORTRAN 77. C C No subroutines and external functions required. C C Date: 1999, January 15 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL F,AUX1,AUX2 C IF(POWER.EQ.0.) THEN DO 1 I=1,N FOUT(I)=0. 1 CONTINUE ELSE IF(0.999.LT.POWER.AND.POWER.LT.1.001) THEN DO 2 I=1,N FOUT(I)=FINP(I) 2 CONTINUE CALL VAR4(0,1.) ELSE IF(FINP(1).LT.0.) THEN C 317 CALL ERROR('317 in FPOWER: Negative material parameter') C Nonunit power of a material parameter is not allowed to be C negative. The negative value may be caused by oscillatory C character of interpolated positive values. ELSE IF(FINP(1).EQ.0.) THEN IF(POWER.LT.0.) THEN C 318 CALL ERROR('318 in FPOWER: Zero inverse material parameter') C Negative power of a material parameter cannot be zero. ELSE FOUT(1)=0. DO 3 I=2,N IF(FINP(I).NE.0.) THEN C 319 CALL ERROR('319 in FPOWER: Zero material parameter') C Nonunit power of zero material parameter is not allowed to C have nonzero derivatives. END IF FOUT(I)=0. 3 CONTINUE END IF ELSE IF(-1.001.LT.POWER.AND.POWER.LT.-0.999) THEN F=1./FINP(1) ELSE F=FINP(1)**(1./POWER) END IF FOUT(1)=F IF(N.GT.1) THEN AUX1= F/(FINP(1)*POWER) AUX2= (POWER-1.)/F FOUT(2)=AUX1*FINP(2) FOUT(3)=AUX1*FINP(3) FOUT(4)=AUX1*FINP(4) IF(N.GT.4) THEN FOUT(5)=AUX1*FINP(5)-AUX2*FOUT(2)*FOUT(2) FOUT(6)=AUX1*FINP(6)-AUX2*FOUT(2)*FOUT(3) FOUT(7)=AUX1*FINP(7)-AUX2*FOUT(3)*FOUT(3) FOUT(8)=AUX1*FINP(8)-AUX2*FOUT(2)*FOUT(4) FOUT(9)=AUX1*FINP(9)-AUX2*FOUT(3)*FOUT(4) FOUT(10)=AUX1*FINP(10)-AUX2*FOUT(4)*FOUT(4) END IF CALL VAR4(0,AUX1) CALL VAR4(2,-AUX2*FOUT(2)) CALL VAR4(3,-AUX2*FOUT(3)) CALL VAR4(4,-AUX2*FOUT(4)) END IF END IF RETURN END C C======================================================================= Cmodle2d.for 0100666 0000765 0000765 00000045566 07305626410 012512 0 ustar bulant bulant C
C Provisional version MODLE2D of the program designed to calculate C directional Lyapunov exponents and the mean Lyapunov exponent C for a 2-D model without interfaces. 3-D models may be used if NY C is specified. C C Version: 5.50 C Date: 2001, June 1 C C Coded by Ludek Klimes C klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C Data specifying the model: C MODEL='string'... String containing the name of the input data C file specifying the model. C Description of file MODEL C No default, MODEL must be specified and cannot be blank. C Data to specify the calculation of Lyapunov exponents: C KOOR1=integer... Index of the first coordinate determining the C 2-D section for the calculation of the Lyapunov exponents. C KOOR1 must be 1, 2 or 3. C Default: KOOR1=1 C KOOR2=integer... Index of the second coordinate determining the C 2-D section for the calculation of the Lyapunov exponents. C KOOR2 must be 1, 2 or 3 and must differ from KOOR1. C Default: KOOR2=2 C NA=integer... Number of angular directions for the calculation of C the directional Lyapunov exponents. C Default: NA=90 C DA... Angular step for the calculation of the directional C Lyapunov exponents. The default value is recommended. C Default: DA=3.141592/NA C OA... The first angle for the calculation of the directional C Lyapunov exponents. The angles are defined in radians, C -pi/2 for positive half-axis KOOR1, 0 for positive C half-axis KOOR2, pi/2 for negative half-axis KOOR1. C The default value is usually sufficient. C Default: OA=-1.570796+0.5*DA C NY=integer... Number of sections for the calculation of each C directional Lyapunov exponent. The sections are C regularly spaced through the model volume. C Default: NY=1 C NX=integer... Number of straight lines for the calculation of C each directional Lyapunov exponent. The lines are C equally spaced and cover the 2-D section of the model C box. C Default: NX=45 C NS=integer... Number of segments along the longest line for the C calculation of a directional Lyapunov exponent. The C length of the segments determined from NS is then used C for all lines corresponding to the direction. C Default: NS=45 C Data to specify the frame of the graph of the Lyapunov exponents: C LEMAX...Value of the Lyapunov exponent corresponding to the top C of the frame. The bottom of the frame cooresponds to 0. C Default: LEMAX=(maximum directional Lyapunov exponent) C ALEMIN..Angle corresponding to the left-hand edge of the frame. C The default value is usually sufficient. C Default: ALEMIN=OA-0.5*DA C ALEMAX..Angle corresponding to the right-hand edge of the frame. C The default value is usually sufficient. C Default: ALEMAX=OA+DA*(NA-0.5) C Names of the output files: C MODLED='string'... Name of the output file containing, for each C angle, the directional Lyapunov exponent. C The file has form C LINes to enable C plotting by program C pictures.for. C The first coordinate of a point of a line is the angle, C the second coordinate is the corresponding directional C Lyapunov exponent. The name of the line is the value of C the maximum directional Lyapunov exponent and the C reference point of the line should enable to draw this C value. C Default: MODLED='modled.out' C MODLEM='string'... Name of the output file containing the mean C Lyapunov exponent for the model (a single value). C The mean Lyapunov exponent is calculated by avaraging C directional Lyapunov exponents with a unit weight. C The file has form C LINes to enable C to plot the mean Lyapunov exponent as a horizontal line C into the graph of the directional Lyapunov exponents. C The line has two points, the first coordinate is the C minimum or maximum angle, respectively. The second C coordinate is the mean Lyapunov exponent. The name of C the line is the value of the mean Lyapunov exponent and C the reference point of the line should enable to draw C this value. C Default: MODLEM='modlem.out' C MODLEF='string'... Name of the output file containing the lines C composing the frame of the graph of the directional C Lyapunov exponents. The file has form C LINes, similarly C as files MODLED and MODLEM. C Default: MODLEF='modlef.out' C C----------------------------------------------------------------------- C C Common block /MODELC/: INCLUDE 'model.inc' C None of the storage locations of the common block are altered. C C----------------------------------------------------------------------- C CHARACTER*80 FILE1 CHARACTER*30 TEXT PARAMETER (LU1=1) LOGICAL LINEND REAL COOR(3),H(3) REAL UP(10),US(10),VD(10),AUX0,AUX1,AUX2,AUX3,AUX4 C C....................................................................... C C Main input data: WRITE(*,'(A)') '+MODLE2D: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF(FILE1.EQ.' ') THEN C MODLE2D-01 CALL ERROR('MODLE2D-01: No input SEP file specified') END IF CALL RSEP1(LU1,FILE1) WRITE(*,'(A)') '+MODLE2D: Working... ' C C Data for model: CALL RSEP3T('MODEL',FILE1,' ') IF(FILE1.EQ.' ') THEN C MODLE2D-02 CALL ERROR('MODLE2D-02: No model specified') END IF OPEN(LU1,FILE=FILE1,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) C C Input parameters CALL RSEP3I('KOOR1',KOOR1,1) CALL RSEP3I('KOOR2',KOOR2,2) CALL RSEP3I('NA',NA,90) CALL RSEP3R('DA',DA,3.141592/FLOAT(NA)) CALL RSEP3R('OA',OA,-1.570796+0.5*DA) IF(OA.LT.-1.570796.OR.OA+DA*FLOAT(NA-1).GT.1.570796) THEN C MODLE2D-03 CALL ERROR('MODLE2D-03: Wrong direction') END IF C Number of sections CALL RSEP3I('NY',NY,1) C Number of lines CALL RSEP3I('NX',NX,45) C Maximum number of steps along a line CALL RSEP3I('NS',NS,45) C C 2-D section BOUND1=BOUNDM(2*KOOR1-1) BOUND2=BOUNDM(2*KOOR1) BOUND3=BOUNDM(2*KOOR2-1) BOUND4=BOUNDM(2*KOOR2) KOOR3=6-KOOR2-KOOR1 BOUND5=BOUNDM(2*KOOR3-1) BOUND6=BOUNDM(2*KOOR3) C C Output file for directional Lyapunov exponents: CALL RSEP3T('MODLED',FILE1,'modled.out') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1) WRITE(LU1,'(A)') '/' END IF C C Loop over directions EL2MOD=0. EL2MAX=0. WRITE(*,'(3(A,I3))') '+MODLE2D:',0,' /',NA,' directions' DO 90 IA=0,NA-1 A=OA+DA*FLOAT(IA) C A is the deviation from the X2 axis in radians O1=BOUND1 O2=BOUND3 D1=BOUND2-BOUND1 D2=BOUND4-BOUND3 DX =(ABS(D1*COS(A))+ABS(D2*SIN(A)))/FLOAT(NX) DS0=(ABS(D1*SIN(A))+ABS(D2*COS(A)))/FLOAT(NS) C *** Initiating averaging over lines NUMSUM=0 TTSUM =0. * ZONSUM=0. * ELASUM=0. * PHISUM=0. * EL1SUM=0. EL2SUM=0. C *** End of initialization DY=(BOUND6-BOUND5)/FLOAT(NY) C Loop over sections DO 85, IY=0,NY-1 COOR(KOOR3)=BOUND5+DY/2.+FLOAT(IY)*DY C Loop over lines DO 80 IX=0,NX-1 C Initial point of the line KS=0 IF(SIN(A).LE.0.) THEN X1=O1+(FLOAT(IX)+0.5)*DX/COS(A) X2=O2 IF(X1.GT.BOUND2) THEN X2=O2+(BOUND2-X1)*COS(A)/SIN(A) X1=BOUND2 END IF ELSE X1=BOUND2-(FLOAT(IX)+0.5)*DX/COS(A) X2=O2 IF(X1.LT.BOUND1) THEN X2=O2+(BOUND1-X1)*COS(A)/SIN(A) X1=BOUND1 END IF END IF C Unit vetor perpendicular to the line H(KOOR1)=COS(A) H(KOOR2)=-SIN(A) H(6-KOOR1-KOOR2)=0. C C *** Initiating numerical quadrature along a part of the line 20 CONTINUE S =0. TT =0. ZON=0. ELA=0. PHI=0. EL0=0. EL1=0. EL2=0. ELAOLD=0. PHIOLD=0. PHI0=0. C *** End of initialization LINEND=.FALSE. C Loop over points of a line DO 70 IS=KS,NS+1 COOR1=X1+DS0*SIN(A)*FLOAT(IS) COOR2=X2+DS0*COS(A)*FLOAT(IS) IF(COOR1.LT.BOUND1) THEN COOR1=BOUND1 COOR2=X2+(COOR1-X1)*COS(A)/SIN(A) LINEND=.TRUE. END IF IF(COOR1.GT.BOUND2) THEN COOR1=BOUND2 COOR2=X2+(COOR1-X1)*COS(A)/SIN(A) LINEND=.TRUE. END IF IF(COOR2.GE.BOUND4) THEN COOR2=BOUND4 COOR1=X1+(COOR2-X2)*SIN(A)/COS(A) LINEND=.TRUE. END IF C COOR1,COOR2 is the current point on the line C *** Beginning of numerical quadrature COOR(KOOR1)=COOR1 COOR(KOOR2)=COOR2 CALL BLOCK(COOR,0,0,ISRF,ISB,ICB) IF(ICB.EQ.0) THEN C Free space VD(1)=0. VV=0. ELSE C Material complex block CALL PARM2(IABS(ICB),COOR,UP,US,AUX0,AUX1,AUX2) CALL VELOC(ICB,UP,US,AUX1,AUX2,AUX3,AUX4,VD,AUX0) V1=VD( 5)*H(1)+VD( 6)*H(2)+VD( 8)*H(3) V2=VD( 6)*H(1)+VD( 7)*H(2)+VD( 9)*H(3) V3=VD( 8)*H(1)+VD( 9)*H(2)+VD(10)*H(3) VV=V1 *H(1)+V2 *H(2)+V3 *H(3) VV=VV/VD(1) IF(IS.GT.KS) THEN DS=SQRT((COOR1-X1OLD)**2+(COOR2-X2OLD)**2) S=S+DS TT=TT+DS*(0.5/VD(1)+0.5/VOLD) IF(VVOLD*VV.GE.0.) THEN ELA=ELA+DS*VVNEG/2. PHI=PHI+DS*VVPOS/2. ELSE ELA=ELA+DS*VVNEG*ABS(VVOLD/(VVOLD-VV))*2./3. PHI=PHI+DS*VVPOS*ABS(VVOLD/(VVOLD-VV))*2./3. END IF IF(VVOLD.LT.0..AND.VV.GE.0.) THEN C End of negative VV ("high velocity") IF(EL0.EQ.0.) THEN C First end of negative VV ("high velocity") EL1=EL1+AMAX1(0.,ELA-ELAOLD) EL2=EL2+AMAX1(0.,ELA-ELAOLD) PHI0=AMIN1(PHI-PHIOLD,0.523599) ELSE EL1=EL1 * +AMAX1(0.,ELA-ELAOLD+ALOG(ABS(COS(PHI-PHIOLD)))) EL2=EL2+AMAX1(0.,ELA-ELAOLD) * +ALOG(COS(AMIN1(PHI-PHIOLD,1.047198))) END IF ZON=ZON+1. EL0=EL0+AMAX1(0.,ELA-ELAOLD) ELAOLD=ELA PHIOLD=PHI END IF VVNEG=SQRT(AMAX1(0.,-VV)) VVPOS=SQRT(AMAX1(0., VV)) IF(VVOLD*VV.GE.0.) THEN ELA=ELA+DS*VVNEG/2. PHI=PHI+DS*VVPOS/2. ELSE ELA=ELA+DS*VVNEG*ABS(VV/(VVOLD-VV))*2./3. PHI=PHI+DS*VVPOS*ABS(VV/(VVOLD-VV))*2./3. END IF END IF END IF IF(LINEND.OR.ICB.EQ.0) THEN C End of the line or its part IF(IS.GT.KS) THEN IF( VV.GE.0.) THEN C Low-velocity EL1=EL1+AMAX1(0.,ELA-ELAOLD) EL2=EL2+AMAX1(0.,ELA-ELAOLD) AUX=AMIN1(PHI-PHIOLD,0.523599) EL2=EL2+0.5*ALOG(1.-SIN(2.*PHI0)*SIN(2.*AUX)) ELSE C High-velocity EL1=EL1 * +AMAX1(0.,ELA-ELAOLD+ALOG(ABS(COS(PHI-PHIOLD)))) EL2=EL2+AMAX1(0.,ELA-ELAOLD) * +ALOG(COS(AMIN1(PHI-PHIOLD,1.047198))) END IF IF(EL0.EQ.0..AND.VV.GT.0.) THEN ZON=ZON+1. END IF EL2=AMAX1(0.,EL2) * NUMSUM=NUMSUM+1 TTSUM =TTSUM +TT C TTSUM =TTSUM +S * ZONSUM=ZONSUM+ZON * ELASUM=ELASUM+ELA * PHISUM=PHISUM+PHI * EL1SUM=EL1SUM+EL1 EL2SUM=EL2SUM+EL2 EL0=EL0+AMAX1(0.,ELA-ELAOLD) IF(ABS(EL0-ELA).GT.0.000010) THEN C C MODLE2D-04 WRITE(TEXT,'(A,F8.3)') 'MODLE2D-04: Wrong EL0=',EL0 CALL ERROR(TEXT) END IF END IF END IF X1OLD=COOR1 X2OLD=COOR2 VOLD=VD(1) VVOLD=VV C *** End of numerical quadrature IF(LINEND) THEN C End of the line GO TO 71 END IF IF(ICB.EQ.0) THEN C Starting the new part of the line from the next point KS=IS+1 GO TO 20 END IF 70 CONTINUE C MODLE2D-05 CALL ERROR('MODLE2D-05: Line endpoint not reached') 71 CONTINUE 80 CONTINUE 85 CONTINUE C *** Results of numerical quadrature * AUX=TTSUM/FLOAT(NUMSUM) * ZON=ZONSUM/TTSUM * ELA=ELASUM/TTSUM * PHI=PHISUM/TTSUM * EL1=EL1SUM/TTSUM EL2=EL2SUM/TTSUM IF(FILE1.NE.' ') THEN IF(IA.EQ.0) THEN WRITE(LU1,'(9(A,F8.3))') '''LE'' /' * WRITE(LU1,'(2F9.3,A)') A,EL2,' M' ELSE * WRITE(LU1,'(2F9.3,A)') A,EL2,' T' END IF WRITE(LU1,'(9(A,F8.3))') ' ',A,' ',EL2,' /' END IF EL2MOD=EL2MOD+EL2 EL2MAX=AMAX1(EL2MAX,EL2) C *** WRITE(*,'(3(A,I3))') '+MODLE2D:',IA+1,' /',NA,' directions' 90 CONTINUE C C Closing output file with directional Lyapunov exponents: IF(FILE1.NE.' ') THEN WRITE(LU1,'(A)') '/' WRITE(LU1,'(A)') '/' CLOSE(LU1) END IF C C Output file with mean Lyapunov exponent: EL2MOD=EL2MOD/FLOAT(NA) CALL RSEP3T('MODLEM',FILE1,'modlem.out') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1) WRITE(LU1,'(A)') '/' AUX=EL2MOD+0.01 WRITE(LU1,'(9(A,F7.3))') '''',EL2MOD,''' ',OA, ' ',AUX ,' /' WRITE(LU1,'(9(A,F7.3))') ' ',OA ,' ',EL2MOD,' /' WRITE(LU1,'(9(A,F7.3))') ' ',OA+DA*FLOAT(NA-1),' ',EL2MOD,' /' WRITE(LU1,'(A)') '/' WRITE(LU1,'(A)') '/' CLOSE(LU1) END IF C C Output file with the frame: CALL RSEP3T('MODLEF',FILE1,'modlef.out') IF(FILE1.NE.' ') THEN CALL RSEP3R('LEMAX' ,EMAX ,EL2MAX) CALL RSEP3R('ALEMIN',ALEMIN,OA-0.5*DA) CALL RSEP3R('ALEMAX',ALEMAX,OA-0.5*DA+DA*FLOAT(NA)) OPEN(LU1,FILE=FILE1) WRITE(LU1,'(A)') '/' WRITE(LU1,'(9(A,F7.3))')'''',EL2MAX,''' ',OA,' ',EL2MAX-.03,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN,' ',EMAX,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMAX,' ',EMAX,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMAX,' ',0. ,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN,' ',0. ,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN,' ',EMAX,' /' WRITE(LU1,'(A)') '/' DO 92 I=0,INT(10.*EMAX+0.01) IF(MOD(I,10).EQ.0) THEN AUX=FLOAT(I/10) IF(I/10.LE.9) THEN WRITE(LU1,'(A,I1,9(A,F7.3))') * '''',I/10,''' ',ALEMIN-0.08,' ',AUX-0.03,' /' ELSE WRITE(LU1,'(A,I2,9(A,F7.3))') * '''',I/10,''' ',ALEMIN-0.16,' ',AUX-0.03,' /' END IF WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN ,' ',AUX ,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN+0.04,' ',AUX ,' /' WRITE(LU1,'(A)') '/' ELSE AUX=FLOAT(I)/10. WRITE(LU1,'(9(A,F7.3))') ''' '' ',ALEMIN-0.10,' ',AUX,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN ,' ',AUX,' /' WRITE(LU1,'(9(A,F7.3))') ' ',ALEMIN+0.02,' ',AUX,' /' WRITE(LU1,'(A)') '/' END IF 92 CONTINUE WRITE(LU1,'(A)') '/' CLOSE(LU1) END IF C WRITE(*,'(A)') '+MODLE2D: 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for C C======================================================================= C modmod.for 0100666 0000765 0000765 00000044606 07356002104 012427 0 ustar bulant bulant CC Program MODMOD to modify the model (update or change parametrization) C C Version: 5.60 C Date: 2001, October 1 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 Program MODMOD assumes all model parameters (coefficients) stored in C the common block /VALC/ as in the submitted versions of user-defined C model specification FORTRAN77 source code files 'srfc.for', 'parm.for' C and 'val.for'. Thus, unlike the other parts of the complete ray C tracing, the MODMOD program cannot work with user's modifications of C subroutines SRFC1, SRFC2, PARM1, and PARM2. 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 original model: C MODEL='string'... String containing the name of the input data C file specifying the original model. C Description of file MODEL C Default: MODEL='model.dat' C Data specifying the modification of the model: C M1='string'... Name of the input file containing the number NM of C model parameters (a single integer). C The file is generated by program 'invsoft.for' and is C used just if MODNEW is specified and is not blank or if C OLDMOD differs from 1. C Default: M1='m1.out' C MODIND='string'... Name of the input file containing the indices C of model parameters. C The file is generated by program 'invsoft.for' and is C used just if MODNEW is specified and is not blank or if C OLDMOD differs from 1.0. C File MODIND C Default: MODIND='modind.out' C MODNEW='string'... Name of the input file containing the updates C of the values of model parameters (coefficients at the C model basis functions). C If blank, original model MODEL is not updated. C File MODNEW C Default: MODNEW=' ' C OLDMOD=real... Percentage of the original model MODEL kept in the C model. For OLDMOD=1.0, original model is updated by the C values stored in file MODPAR. For OLDMOD=0.0, original C model is discarded and replaced by the values stored in C file MODPAR (in such a case, MODPAR should contain C complete parameter values instead of their updates). C Default: OLDMOD=1.0 C Form of the files with matrices (file MODNEW): C FORMM='string' ... Form of the files with matrices. Allowed values C are FORMM='formatted' and FORMM='unformatted'. If the form C differs for input and for output files, FORMMR and FORMMW C should be used instead of FORMM. C Default: FORMM='formatted' C FORMMR='string' ... Form of the files with matrices to be read. C Default: FORMMR=FORMM C Data specifying the form and name of the output model file: C MODIN='string'... Name of the file describing the form of the C parametrization of the output model. If no changes in the C parametrization of the model are required, the default C value (value of parameter MODEL) is appropriate. C The functional values describing surfaces and material C parameters in file MODIN do not influence the resulting C model and may thus be arbitrary. C Description of file MODIN C Default: MODIN=MODEL C MODOUT='string'... Name of the output file describing the new C model. File MODOUT is a copy of file MODIN, with the C functional values replaced by new ones. C Description of file MODOUT C Default: MODOUT='model.out' C C======================================================================= C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C....................................................................... C C Common block /VALC/: INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C....................................................................... C C Subroutines and external functions required: EXTERNAL ERROR,RSEP1,RSEP3T,RSEP3R,MODEL1,NEWMOD,NEWVAL,OMAT C C....................................................................... C C Filenames and parameters: CHARACTER*80 FILE1,FILE2,FILE3 INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) C C Auxiliary storage locations: CHARACTER*13 FORMM INTEGER NSRF,NCB,M1,I REAL OLDMOD CHARACTER*3 TSRF(1),TCB(47) DATA TSRF/' '/ DATA TCB/'VP ','VS ','DEN','QP ','QS ', *'A11','A12','A22','A13','A23','A33','A14','A24','A34','A44', *'A15','A25','A35','A45','A55','A16','A26','A36','A46','A56','A66', *'Q11','Q12','Q22','Q13','Q23','Q33','Q14','Q24','Q34','Q44', *'Q15','Q25','Q35','Q45','Q55','Q16','Q26','Q36','Q46','Q56','Q66'/ C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+MODMOD: Enter input filename: ' FILE1=' ' READ(*,*) FILE1 IF(FILE1.EQ.' ') THEN C MODMOD-01 CALL ERROR('MODMOD-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)') '+MODMOD: Working... ' CALL RSEP1(LU1,FILE1) C C Checking input data MODIN: CALL RSEP3T('MODEL',FILE2,'model.dat') CALL RSEP3T('MODIN',FILE1,FILE2) IF(FILE1.NE.FILE2) THEN OPEN(LU1,FILE=FILE1,STATUS='OLD') CALL MODEL1(LU1) CLOSE(LU1) IPAR(0)=0 END IF C C Reading input data MODEL for the model to be updated: OPEN(LU2,FILE=FILE2,STATUS='OLD') CALL MODEL1(LU2) CLOSE(LU2) C C Updating the model corresponding to data MODEL: CALL RSEP3T('MODNEW',FILE2,' ') C Reading percentage of old model parameters CALL RSEP3R('OLDMOD',OLDMOD,1.00) IF(FILE2.NE.' '.OR.OLDMOD.NE.1.0) THEN CALL RSEP3T('M1',FILE3,'m1.out') OPEN(LU2,FILE=FILE3,STATUS='OLD') READ(LU2,*) M1 CLOSE(LU2) IF(2*M1.GT.MRAM) THEN C MODMOD-02 CALL ERROR('MODMOD-02: Too many model parameters') END IF C Reading indices of model parameters CALL RSEP3T('MODIND',FILE3,'modind.out') OPEN(LU2,FILE=FILE3,STATUS='OLD') READ(LU2,*) (IRAM(I),I=1,M1) CLOSE(LU2) IF(FILE2.NE.' ') THEN C Reading increments of model parameters CALL OMAT(LU2,FILE2,1,FORMM) IF (FORMM.EQ.'formatted') THEN READ(LU2,*) (RAM(I),I=M1+1,2*M1) ELSE READ(LU2) (RAM(I),I=M1+1,2*M1) ENDIF CLOSE(LU2) C Updating the model DO 11 I=1,M1 RPAR(IRAM(I))=RPAR(IRAM(I))*OLDMOD+RAM(M1+I) 11 CONTINUE ELSE C Updating the model DO 12 I=1,M1 RPAR(IRAM(I))=RPAR(IRAM(I))*OLDMOD 12 CONTINUE END IF END IF C C Converting input data MODIN into output data MODOUT: CALL RSEP3T('MODOUT',FILE2,'model.out' ) OPEN(LU1,FILE=FILE1,STATUS='OLD') OPEN(LU2,FILE=FILE2) CALL NEWMOD(LU1,LU2,NSRF,NCB) CALL NEWVAL(LU1,LU2,1,NSRF,1,TSRF) CALL NEWVAL(LU1,LU2,2,NCB,47,TCB) CLOSE(LU1) CLOSE(LU2) WRITE(*,'(A)') '+MODMOD: Done. ' C STOP END C C======================================================================= C SUBROUTINE NEWMOD(LU1,LU2,NSRF,NCB) INTEGER LU1,LU2,NSRF,NCB C C Subroutines and external functions required: EXTERNAL NEWLIN C C----------------------------------------------------------------------- C CHARACTER*1 TEXTM INTEGER I,J,K,N,NEXPV,NEXPQ,NSB REAL AUX C C....................................................................... C C Model description: N=0 11 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=11) TEXTM C C Model indices: N=0 12 CONTINUE CALL NEWLIN(LU1,LU2,N) NEXPV=1 NEXPQ=1 READ(LU2,*,END=12) I,NEXPV,NEXPQ,I C C Model boundaries: N=0 13 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=13) (AUX,I=1,6) C C Number of surfaces: N=0 14 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=14) NSRF C C Number of simple blocks: N=0 20 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=20) NSB C C Indices of surfaces bounding simple blocks: DO 22 J=1,NSB N=0 21 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=21) (K,I=1,99) 22 CONTINUE C C Number of complex blocks: N=0 30 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=30) NCB C C Indices of simple blocks forming complex blocks: DO 32 J=1,NCB N=0 31 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=31) (K,I=1,99) 32 CONTINUE C RETURN END C C======================================================================= C SUBROUTINE NEWVAL(LU1,LU2,ICLASS,NGROUP,NFUNCT,TFUNCT) INTEGER LU1,LU2,ICLASS,NGROUP,NFUNCT CHARACTER*(*) TFUNCT(NFUNCT) C C Common block /VALC/: INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL ERROR,WARRAY,VAL2,NEWLIN,LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C C Common block /RAMC/: INCLUDE 'ram.inc' C ram.inc C C....................................................................... C CHARACTER*3 TEXT CHARACTER*120 LINE CHARACTER*40 FORMAT LOGICAL WHAT INTEGER NVAR,IVAR(3),NX(3),MX,IGROUP,IFUNCT,JFUNCT,IADR INTEGER I1,I2,I3,I,N REAL GROUP,POWERW,COOR(3),F(10,47),POWER(47),AUX C C....................................................................... C C Flag if the physical meaning of the functions is included in the C input data: WHAT=.FALSE. DO 10 I=1,NFUNCT IF(TFUNCT(I).NE.' ') WHAT=.TRUE. 10 CONTINUE C C Loop for groups of functions: N=0 11 CONTINUE CALL NEWLIN(LU1,LU2,N) GROUP=1. READ(LU2,*,END=11) TEXT,GROUP DO 90 IGROUP=1,NGROUP C C Loop for functions of the current group: DO 80 IFUNCT=1,NFUNCT C C Physical meaning of the function: IF(WHAT) THEN N=0 21 CONTINUE CALL NEWLIN(LU1,LU2,N) GROUP=1. READ(LU2,*,END=21) TEXT,GROUP DO 22 I=1,NFUNCT IF(TFUNCT(I).EQ.TEXT) THEN JFUNCT=I GO TO 23 END IF 22 CONTINUE GO TO 89 23 CONTINUE ELSE JFUNCT=IFUNCT END IF C C Initial address of the function parameters: I2=IPAR(ICLASS-1)+IGROUP DO 25 I1=IPAR(I2-1)+1,IPAR(I2-1)+NFUNCT IADR=IPAR(I1-1) IF(IPAR(IADR+1).EQ.JFUNCT) THEN GO TO 26 END IF 25 CONTINUE C MODMOD-04 CALL ERROR('MODMOD-04: Function not found') C Function specified in data MODIN has not been specified in C data MODEL. 26 CONTINUE C C Reading spline grid: DO 31 I=1,3 IVAR(I)=0 NX(I)=1 31 CONTINUE N=0 32 CONTINUE CALL NEWLIN(LU1,LU2,N) IVAR(1)=0 IVAR(2)=0 IVAR(3)=0 POWERW=1. READ(LU2,*,END=32) (IVAR(I),I=1,3),AUX,POWERW NVAR=3 I2=0 41 CONTINUE I2=I2+1 IF(IVAR(I2).LE.0) THEN NVAR=NVAR-1 DO 42 I1=I2,NVAR IVAR(I1)=IVAR(I1+1) 42 CONTINUE I2=I2-1 END IF IF(I2.LT.NVAR) GO TO 41 IF(NVAR.GT.0) THEN N=0 44 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=44) (NX(I),I=1,NVAR) END IF MX=MAX0(NX(1),NX(2),NX(3)) RAM( 1)=0. RAM( MX+1)=0. RAM(2*MX+1)=0. IF(4*MX.GT.MRAM) THEN C MODMOD-03 CALL ERROR('MODMOD-03: Small array RAM') END IF DO 46 I2=1,NVAR IF(NX(I2).GT.0) THEN N=0 45 CONTINUE CALL NEWLIN(LU1,LU2,N) READ(LU2,*,END=45) * (RAM(I1),I1=(I2-1)*MX+1,(I2-1)*MX+NX(I2)) ELSE NX(I2)=1 END IF 46 CONTINUE READ(LU1,*) (AUX,I=1,NX(1)*NX(2)*NX(3)) C C Changing coordinate indices to 1,2,3: DO 53 I2=3,5 IF(IPAR(IADR+I2).LE.0) THEN IPAR(IADR+I2)=0 ELSE DO 51 I1=1,NVAR IF(IPAR(IADR+I2).EQ.IVAR(I1)) THEN IPAR(IADR+I2)=I1 GO TO 52 END IF 51 CONTINUE C MODMOD-05 CALL ERROR('MODMOD-05: Wrong independent variable') C Function in data MODEL depends on different variables C than the corresponding function in data MODIN. 52 CONTINUE END IF 53 CONTINUE C C Calculating and writing grid values of the given function: DO 63 I3=1,NX(3) IF(NX(1).NE.1.AND.NX(2).NE.1.AND.NX(3).NE.1) THEN C Separating 2-D slices of 3-D grid by a blank line WRITE(LU2,*) END IF COOR(3)=RAM(2*MX+I3) DO 62 I2=1,NX(2) COOR(2)=RAM(MX+I2) DO 61 I1=1,NX(1) COOR(1)=RAM(I1) CALL VAL2(ICLASS,IGROUP,NFUNCT,COOR,F,POWER) AUX=GROUP*POWERW/POWER(JFUNCT) RAM(3*MX+I1)=F(1,JFUNCT) IF(WHAT) THEN IF(AUX.NE.1.) THEN IF(RAM(3*MX+I1).GE.0.) THEN RAM(3*MX+I1)=RAM(3*MX+I1)**AUX ELSE FORMAT='(A,I2,A,I2,A,' CALL FORM2(3,COOR,COOR,FORMAT(14:37)) C C MODMOD-06 WRITE(LINE,FORMAT) * 'MODMOD-06: Negative value. Block',IGROUP, * ', function',JFUNCT, * ', coordinates ',COOR(1),' ',COOR(2),' ',COOR(3) CALL ERROR(LINE(1:LENGTH(LINE))) C Function with negative values is interpolated C while its non-unit power should be written. C Such an operation is not permitted. END IF END IF END IF 61 CONTINUE CALL WARRAY(LU2,' ','FORMATTED',.FALSE.,0.,.FALSE.,0., * NX(1),RAM(3*MX+1)) 62 CONTINUE 63 CONTINUE 80 CONTINUE C End of loop for functions C N=0 81 CONTINUE CALL NEWLIN(LU1,LU2,N) GROUP=1. READ(LU2,*,END=81) TEXT,GROUP 89 CONTINUE 90 CONTINUE C End of loop for groups of functions C RETURN END C C======================================================================= C SUBROUTINE NEWLIN(LU1,LU2,N) INTEGER LU1,LU2,N C C Subroutines and external functions required: EXTERNAL LENGTH INTEGER LENGTH C C----------------------------------------------------------------------- C CHARACTER*160 LINE INTEGER I C C....................................................................... C C Returning from the position after the end of file: IF(N.GT.0) THEN BACKSPACE(LU2) END IF C C Copying one more line: READ (LU1,'(A)') LINE WRITE(LU2,'(A)') LINE(1:LENGTH(LINE)) N=N+1 C C Rewinding to the position before reading: DO 10 I=1,N BACKSPACE(LU2) 10 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for C C======================================================================= Cmod.pl 0100666 0000765 0000765 00000003611 06765373322 011563 0 ustar bulant bulant #!perl ## # Perl script file 'mod.pl' to modify FORTRAN77 source code files # 'model.for', 'parm.for', 'val.for' and 'fit.for', # containing the model routines required when solving forward # problems, in order to yield FORTRAN77 source code files # 'modelv.for', 'parmv.for', 'valv.for' and 'fitv.for', # containing the model routines required when solving inverse # problems. # require 'go.pl'; # &RUN("clean","'model.for' 'modelv.for' '*V' ' ' /"); &RUN("clean","'parm.for' 'parmv.for' '*V' ' ' /"); &RUN("clean","'val.for' 'valv.for' '*V' ' ' /"); &RUN("clean","'fit.for' 'fitv.for' '*V' ' ' /"); # # ---------------------------------------------------------------------- # # 'model.for', 'parm.for', 'val.for' and 'fit.for' are used, e.g., by # (A) the 'grid.for' program, # (B) the 'sec.for' program, # (C) the 'intf.for' program, # (D) the complete ray tracing program. # # The derived files 'modelv.for', 'parmv.for', 'valv.for' and # 'fitv.for' are used, e.g., by # (I) the 'invtt.for' program of the CRT package, generating the # linearized system of equations for model parameters. # # The derived files 'modelv.for', 'parmv.for', 'valv.for' and # 'fitv.for' have all the functionality of files 'model.for', # 'parm.for', 'val.for' and 'fit.for' for the purposes of forward # modelling, and many inverse modelling functions on # the top of it if linked with 'var.for'. On the other hand, are # slower. # The derived files 'modelv.for', 'parmv.for', 'valv.for' and # 'fitv.for' with 'varnul.for' instead of 'var.for' are # very close to 'model.for', 'parm.for', 'val.for' and 'fit.for' # in performance, see the table in the file 'var.for'. # # ====================================================================== 1; #modsrf.for 0100666 0000765 0000765 00000327743 07443313504 012456 0 ustar bulant bulant CC Program MODSRF for coverage of structural interfaces by polygons C and for computation of 2-D slices through a model. C C Version: 5.60 C Date: 2002, March 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 Structural interfaces: C Structural interfaces are in MODEL package defined by implicit C functions. This is very useful for computation purposes, but not very C useful for visualization of models. For visualization purposes the C interfaces must be expressed in explicit form, e.g. as sets of C polygons composed of points with known coordinates. C Program MODSRF covers structural interfaces by polygons composed C of points with known cartesian coordinates. C Method: The model is decomposed into a set of cubes given by input C parameters Oi, Ni, Di. Points of intersections of cube edges with C structural interfaces are computed together with points of C intersection of structural edges with faces of the cubes. Points C which belong to the same interface are then connected into C polygons for each cube. C This mode is started if all N1, N2, N3 are greater than 1. C C 2-D sections: C If one of the values N1, N2, N3 equal 1, the 2-D sections are C generated. Above mentioned points of intersection are computed C along rectangles given by Oi, Ni, Di. Points which belong to the C same complex block are then connected into polygons for each C rectangle. C C Problems may occur, when some gridpoints of the basic grid are located C exactly at the structural interfaces or even at the structural edges, C or even when cube edges coincide with structural interfaces or even C with the structural edges. In such situations the program may C collapse or its results may contain huge numerical errors. C To solve such problems, it is reccomended to slightly shift the basic C grid (if possible), or to decrease input parameter ERRSRF. 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 model by means of the MODEL package: C MODEL='string'... Name of the input file with the data specifying C the model. Cartesian coordinates must be used C in file MODEL. C Description of MODEL C Example of MODEL C No default, 'MODEL' must be specified and cannot be blank. 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 The values of N1, N2, N3 also decide about the mode in C which MODSRF runs: C all of N1,N2,N3 greater 1: computation of polygons along C structural interfaces. C one of N1,N2,N3 equal 1: computation of polygons along C 2-D section through the model. 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 The grid intervals may also be negative. C Names of the output files: C VRTX='string'... Name of the output file with vertices of the C polygons. Description of file VRTX. C Default: VRTX='vrtx.out' C PLGN='string'... Name of the output file describing the polygons. C If blank, the file is not generated. C Description of file PLGN. C Default: PLGN='plgn.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=' ' (the file is not generated) C Parameters specifying the quantities to be written into the file VRTX. C TEXTP='string' ... First part of names of vertices. The second C part of the name of a vertex is formed by number giving C its position in the file VRTX. C Default: TEXTP='V' C COLUMN01 to COLUMN69, POWER01 to POWER69, IVALUE01 to IVALUE69: C IVALUEii=integer ... An integer value required for some special C values of COLUMNii. See, e.g., description of COLUMNii C in case that COLUMNii='SRF'. C POWERii=real ... Power of the quantity to be written in column ii. C COLUMNii='string' ... String which specifies the quantity to be C written to the column ii of the file VRTX. First six C columns usually contain coordinates of the vertices and C the normals. Column zero is reserved for names of the C vertices. Following strings are allowed: C ' ' (a space) ... Nothing is to be written to the column C ii and to all the following columns. C 'X1' ... First coordinate of the vertex. C 'X2' ... Second coordinate of the vertex. C 'X3' ... Third coordinate of the vertex. C 'NORM1' ... First component of the normal to the interface C (or to the 2-D slice) at the vertex. C 'NORM2' ... Second component of the normal. C 'NORM3' ... Third component of the normal. C 'ISRF' ... Index of the interface. C '+ISB' ... Index of simple block at positive side of the C interface. C '-ISB' ... Index of simple block at negative side of the C interface. C '+ICB' '-ICB' ... Index of complex block. C '+VP' '-VP' ... P-wave velocity. C '+VS' '-VS' ... S-wave velocity. C '+DEN' '-DEN' ... Density. C '+QP' '-QP' ... P wave loss factor. C '+QS' '-QS' ... S wave loss factor. C '+A11' '-A11' '+A12' '-A12' '+A22' '-A22' '+A13' '-A13' C '+A23' '-A23' '+A33' '-A33' '+A14' '-A14' '+A24' '-A24' C '+A34' '-A34' '+A44' '-A44' '+A15' '-A15' '+A25' '-A25' C '+A35' '-A35' '+A45' '-A45' '+A55' '-A55' '+A16' '-A16' C '+A26' '-A26' '+A36' '-A36' '+A46' '-A46' '+A56' '-A56' C '+A66' '-A66' ... Reduced (i.e. divided by the density) C anisotropic elastic parameters C (components of the real part of the symmetric 6*6 C stiffness matrix divided by the density). C '+Q11' '-Q11' '+Q12' '-Q12' '+Q22' '-Q22' '+Q13' '-Q13' C '+Q23' '-Q23' '+Q33' '-Q33' '+Q14' '-Q14' '+Q24' '-Q24' C '+Q34' '-Q34' '+Q44' '-Q44' '+Q15' '-Q15' '+Q25' '-Q25' C '+Q35' '-Q35' '+Q45' '-Q45' '+Q55' '-Q55' '+Q16' '-Q16' C '+Q26' '-Q26' '+Q36' '-Q36' '+Q46' '-Q46' '+Q56' '-Q56' C '+Q66' '-Q66' ... Reduced (i.e. divided by the density) C imaginary anisotropic elastic parameters C (components of the imaginary part of the C symmetric 6*6 stiffness matrix divided by the density). C 'SRF' ... Value of the function describing a surface C with index IVALUEii (IVALUEii must be specified in C addition to the COLUMNii='SRF'). C All strings may be entered either in uppercase or in C lowercase letters. C Defaults: COLUMN01='X1', COLUMN02='X2', COLUMN03='X3', C COLUMN04='NORM1', COLUMN05='NORM2', COLUMN06='NORM3', C COLUMN07='ISRF', COLUMN08 to COLUMN69=' ', C POWER01 to POWER69=1, IVALUE01 to IVALUE69=1. C Upper error bound in the position of points at interfaces: C ERRSRF=real ... The upper error bound. C Default: ERRSRF=(D1+D2+D3)/3000. (mostly sufficient) C Parameter to decide, whether the polygons composed of points C situated in free space are to be written to the files PLGN and/or C PLGNS. Important mainly for 2-D slices. C FREESRF=real ... the polygons in free space are written to the C output files only if FREESRF=1. C Default: FREESRF=0. (polygons in free space not written) 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',R1,R2,... / C 'NAME'... Name of the vertex. See parameter TEXTP above. C R1,R2,... /... None to several values terminated by a slash. See C parameters COLUMN01 to COLUMN69 above. C (3) / ... a slash at the end of file. C C C Output file PLGN with the polygons specified in terms of C indices of vertices: 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 is terminated by a slash. C (2) / ... a slash at the end of file. C C C Output file PLGNS with the polygons specified in terms of C names of vertices. This enables vertices from several files C to be combined in further application (the names of the vertices must C differ, see the parameter TEXTP above). 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 correspond to the C names in file VRTX. C /... List of vertices is terminated by a slash. C (2) / ... a slash at the end of file. C C----------------------------------------------------------------------- C Subroutines and external functions required: EXTERNAL MSLPIF,MSLPIL,FCTMS,OUTMS,MSGLEG,MSGFAC,MSGCUB,MSGCGP, *MSXFAC,MSCP,MSEROR, *ERROR,RSEP1,RSEP3T,RSEP3R,RSEP3I,FORM1,LOWER,LENGTH, *MODEL1,BLOCK,BLOCKS,SEPAR,CDE,SRFC2,PARM2,PARM3,RKGS LOGICAL MSLPIF,MSLPIL INTEGER LENGTH C MSLPIF,MSLPIL,FCTMS,OUTMS,MSGLEG,MSGFAC,MSGCUB,MSGCGP, C MSXFAC,MSCP,MSEROR ... This file. C ERROR ... File error.for. C RSEP1,RSEP3T,RSEP3R,RSEP3I ... C File sep.for. C FORM1,LOWER ... forms.for. C LENGTH ... length.for. C MODEL1,BLOCK,BLOCKS,SEPAR ... C File model.for. C CDE ... File means.for. C SRFC2 ... srfc.for. C PARM2,PARM3 ... parm.for. C RKGS ... File rkgs.for. 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 'modsrf.inc' C modsrf.inc. C ........................... C Input and output data files: CHARACTER*80 FSEP,FMOD INTEGER LU,LU1,LU2 PARAMETER (LU=1,LU1=1,LU2=2) C Auxiliary storage locations: INTEGER I1,I2,I3,I4,I5,I6,I7,J1,J2,J3,ITER,NPOINT,LEN1,LEN2,LENG INTEGER IL1,IL2,IL3,IL4,IF1,IF2,IF3,IF4,IF5,IF6 INTEGER IX,IP1,IP2,ISHIFT INTEGER ISBOLD,ICBOLD,ISBNEW,ICBNEW,ISRF,ICBPOS,ICBNEG REAL X1,X2,X3,XX(3),Y1,Y2,Y3,YY(3) EQUIVALENCE (X1,XX(1)),(X2,XX(2)),(X3,XX(3)) EQUIVALENCE (Y1,YY(1)),(Y2,YY(2)),(Y3,YY(3)) REAL F(10),FF(10) INTEGER IDUMMY(1),IY(8),IB REAL ERRSRF,DUMMY(1),XOLD1,XOLD(3),DOLD(3),XNEW1,XNEW(3),DNEW(3), * XTMP1,XTMP(3),DTMP(3),XINT1,XINT(3),DINT(3),FRESRF LOGICAL LFREE REAL PRMT(5),AUX(8,3) INTEGER MJPT,NJPT PARAMETER (MJPT=8) INTEGER JPT(6,MJPT) C JPT(1 to 6,i) ... Points along the gridface: address of the point, C ICB,ISB,ISRF,ISB,ICB. JPT(1,i).LT.0 means that the point is C stored in reverse order than it is in IRAM. INTEGER MJCN,NJCN,NNJCN(0:7),MJPOL,NJPOL,MLJPOL,NLJPOL,NIND PARAMETER (MJCN=50,MJPOL=10,MLJPOL=10) INTEGER JCN(4,MJCN),JPOL(0:MLJPOL,MJPOL),IND(MJCN) C JCN(1 to 4,i) ... Connection i of the face: address of the first C point, address of the second point, index of the interface, C status of the connection. C NNJCN(1:7) ... Number of connections for first gridface, second C gridface, ... , sixth gridface, between edges. C JPOL(0,i) ... Number of points in polygon i. C JPOL(1 to JPOL(0,i),i) ... Points in the polygon. INTEGER MIPTE PARAMETER (MIPTE=5) INTEGER IPTE(MIPTE),NIPTE C IPTE(i) ... address of the point to be used as starting point C when searching for the edge. IPTE(i).LT.0 means that the point C is to be used in reverse order than it is stored in array IRAM. INTEGER IVALUE(69) REAL Z(69),POWER(69),VP(10),VS(10),RHO,QP,QS,A(10,21),Q(21), * OUTMIN,OUTMAX LOGICAL LCN CHARACTER*20 FORMAT,FORMA1,FORMA2,FORMA3,VRTX,PLGN,PLGNS,TEXTP, * TEXTC(69)*5,TEXTS(MLJPOL),TEXT C C....................................................................... C C Reading name of SEP file with input data: WRITE(*,'(A)') '+MODSRF: Enter input filename: ' FSEP=' ' READ(*,*) FSEP C C Reading all data from the SEP file into the memory: IF (FSEP.EQ.' ') THEN C MODSRF-32 CALL ERROR('MODSRF-32: 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',D1,1.) CALL RSEP3R('D2',D2,1.) CALL RSEP3R('D3',D3,1.) IF (D1.LT.0.) THEN O1=O1+(N1-1)*D1 D1=-D1 ENDIF IF (D2.LT.0.) THEN O2=O2+(N2-1)*D2 D2=-D2 ENDIF IF (D3.LT.0.) THEN O3=O3+(N3-1)*D3 D3=-D3 ENDIF IF ((N1.LE.0).OR.(N2.LE.0).OR.(N3.LE.0).OR. * ((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 MODSRF-01 CALL ERROR('MODSRF-01: Wrong specification of the grid.') C This specification of the grid may cause problems. Please, C specify D1,D2,D3 nonzero and N1,N2,N3 greater than 0. Di may C equal zero in case that corresponding Ni equals 1. ENDIF C C Reading the data for the model: CALL RSEP3T('MODEL',FMOD,' ') IF (FMOD.EQ.' ') THEN C MODSRF-33 CALL ERROR('MODSRF-33: MODEL not given') C Input file MODEL with the model must be specified. C There is no default filename. ENDIF OPEN(LU,FILE=FMOD,STATUS='OLD') CALL MODEL1(LU) CLOSE(LU) C C Recalling the output filenames: CALL RSEP3T('VRTX',VRTX,'vrtx.out') CALL RSEP3T('PLGN',PLGN,'plgn.out') CALL RSEP3T('PLGNS',PLGNS,' ') C C Recalling the first part of names of points in output file VRTX: CALL RSEP3T('TEXTP',TEXTP,'V') C C Recalling the data specifying the quantities to be written into C the output file with points at structural interfaces: FORMA1='COLUMN00' FORMA2='POWER00' FORMA3='IVALUE00' I1=1 5 CONTINUE FORMA1(8:8)=CHAR(ICHAR('0')+MOD(I1,10)) FORMA2(7:7)=FORMA1(8:8) FORMA3(8:8)=FORMA1(8:8) FORMA1(7:7)=CHAR(ICHAR('0')+I1/10) FORMA2(6:6)=FORMA1(7:7) FORMA3(7:7)=FORMA1(7:7) IF (I1.EQ.1) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'X1') ELSEIF (I1.EQ.2) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'X2') ELSEIF (I1.EQ.3) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'X3') ELSEIF (I1.EQ.4) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'NORM1') ELSEIF (I1.EQ.5) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'NORM2') ELSEIF (I1.EQ.6) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'NORM3') ELSEIF (I1.EQ.7) THEN CALL RSEP3T(FORMA1,TEXTC(I1),'ISRF') ELSE CALL RSEP3T(FORMA1,TEXTC(I1),' ') ENDIF CALL RSEP3R(FORMA2,POWER(I1),1.) CALL RSEP3I(FORMA3,IVALUE(I1),1) IF (TEXTC(I1).NE.' ') THEN CALL LOWER(TEXTC(I1)) IF ((TEXTC(I1).NE.'x1').AND.(TEXTC(I1).NE.'x2').AND. * (TEXTC(I1).NE.'x3').AND.(TEXTC(I1).NE.'norm1').AND. * (TEXTC(I1).NE.'norm2').AND.(TEXTC(I1).NE.'norm3').AND. * (TEXTC(I1).NE.'isrf').AND. * (TEXTC(I1).NE.'+isb').AND.(TEXTC(I1).NE.'-isb').AND. * (TEXTC(I1).NE.'+icb').AND.(TEXTC(I1).NE.'-icb').AND. * (TEXTC(I1).NE.'+vp') .AND.(TEXTC(I1).NE.'-vp') .AND. * (TEXTC(I1).NE.'+vs') .AND.(TEXTC(I1).NE.'-vs') .AND. * (TEXTC(I1).NE.'+den').AND.(TEXTC(I1).NE.'-den').AND. * (TEXTC(I1).NE.'+qp') .AND.(TEXTC(I1).NE.'-qp') .AND. * (TEXTC(I1).NE.'+qs') .AND.(TEXTC(I1).NE.'-qs') .AND. * (TEXTC(I1).NE.'+a11').AND.(TEXTC(I1).NE.'-a11').AND. * (TEXTC(I1).NE.'+a12').AND.(TEXTC(I1).NE.'-a12').AND. * (TEXTC(I1).NE.'+a22').AND.(TEXTC(I1).NE.'-a22').AND. * (TEXTC(I1).NE.'+a13').AND.(TEXTC(I1).NE.'-a13').AND. * (TEXTC(I1).NE.'+a23').AND.(TEXTC(I1).NE.'-a23').AND. * (TEXTC(I1).NE.'+a33').AND.(TEXTC(I1).NE.'-a33').AND. * (TEXTC(I1).NE.'+a14').AND.(TEXTC(I1).NE.'-a14').AND. * (TEXTC(I1).NE.'+a24').AND.(TEXTC(I1).NE.'-a24').AND. * (TEXTC(I1).NE.'+a34').AND.(TEXTC(I1).NE.'-a34').AND. * (TEXTC(I1).NE.'+a44').AND.(TEXTC(I1).NE.'-a44').AND. * (TEXTC(I1).NE.'+a15').AND.(TEXTC(I1).NE.'-a15').AND. * (TEXTC(I1).NE.'+a25').AND.(TEXTC(I1).NE.'-a25').AND. * (TEXTC(I1).NE.'+a35').AND.(TEXTC(I1).NE.'-a35').AND. * (TEXTC(I1).NE.'+a45').AND.(TEXTC(I1).NE.'-a45').AND. * (TEXTC(I1).NE.'+a55').AND.(TEXTC(I1).NE.'-a55').AND. * (TEXTC(I1).NE.'+a16').AND.(TEXTC(I1).NE.'-a16').AND. * (TEXTC(I1).NE.'+a26').AND.(TEXTC(I1).NE.'-a26').AND. * (TEXTC(I1).NE.'+a36').AND.(TEXTC(I1).NE.'-a36').AND. * (TEXTC(I1).NE.'+a46').AND.(TEXTC(I1).NE.'-a46').AND. * (TEXTC(I1).NE.'+a56').AND.(TEXTC(I1).NE.'-a56').AND. * (TEXTC(I1).NE.'+a66').AND.(TEXTC(I1).NE.'-a66').AND. * (TEXTC(I1).NE.'+q11').AND.(TEXTC(I1).NE.'-q11').AND. * (TEXTC(I1).NE.'+q12').AND.(TEXTC(I1).NE.'-q12').AND. * (TEXTC(I1).NE.'+q22').AND.(TEXTC(I1).NE.'-q22').AND. * (TEXTC(I1).NE.'+q13').AND.(TEXTC(I1).NE.'-q13').AND. * (TEXTC(I1).NE.'+q23').AND.(TEXTC(I1).NE.'-q23').AND. * (TEXTC(I1).NE.'+q33').AND.(TEXTC(I1).NE.'-q33').AND. * (TEXTC(I1).NE.'+q14').AND.(TEXTC(I1).NE.'-q14').AND. * (TEXTC(I1).NE.'+q24').AND.(TEXTC(I1).NE.'-q24').AND. * (TEXTC(I1).NE.'+q34').AND.(TEXTC(I1).NE.'-q34').AND. * (TEXTC(I1).NE.'+q44').AND.(TEXTC(I1).NE.'-q44').AND. * (TEXTC(I1).NE.'+q15').AND.(TEXTC(I1).NE.'-q15').AND. * (TEXTC(I1).NE.'+q25').AND.(TEXTC(I1).NE.'-q25').AND. * (TEXTC(I1).NE.'+q35').AND.(TEXTC(I1).NE.'-q35').AND. * (TEXTC(I1).NE.'+q45').AND.(TEXTC(I1).NE.'-q45').AND. * (TEXTC(I1).NE.'+q55').AND.(TEXTC(I1).NE.'-q55').AND. * (TEXTC(I1).NE.'+q16').AND.(TEXTC(I1).NE.'-q16').AND. * (TEXTC(I1).NE.'+q26').AND.(TEXTC(I1).NE.'-q26').AND. * (TEXTC(I1).NE.'+q36').AND.(TEXTC(I1).NE.'-q36').AND. * (TEXTC(I1).NE.'+q46').AND.(TEXTC(I1).NE.'-q46').AND. * (TEXTC(I1).NE.'+q56').AND.(TEXTC(I1).NE.'-q56').AND. * (TEXTC(I1).NE.'+q66').AND.(TEXTC(I1).NE.'-q66').AND. * (TEXTC(I1).NE.'srf')) THEN C MODSRF-02 CALL ERROR('MODSRF-02: Wrong value of COLUMN.') C See allowed values of COLUMNii in the C description of file SEP. ENDIF I1=I1+1 IF (I1.GT.69) THEN CALL RSEP3T('COLUMN70',TEXT,' ') IF (TEXT.NE.' ') THEN C MODSRF-03 CALL ERROR('MODSRF-03: More than 69 COLUMNs.') C Currently up to 69 values of COLUMNii may be specified. C See allowed values of COLUMNii in the C description of file SEP. ENDIF ELSE GOTO 5 ENDIF ENDIF C End of the loop over future columns of the output file. C C Maximum allowed error in the position of interfaces: CALL RSEP3R('ERRSRF',ERRSRF,(D1+D2+D3)/3000.) C C Parameter to decide about writing of the polygons situated C in free space: CALL RSEP3R('FREESRF',FRESRF,0.) IF (FRESRF.EQ.1.) THEN LFREE=.TRUE. ELSE LFREE=.FALSE. ENDIF C C Preparing numbers of gridpoints, gridlegs, gridfaces C and gridcubes: N11=N1-1 N21=N2-1 N1N2= N1 * N2 N11N2= (N1-1)* N2 N1N21= N1 *(N2-1) N11N21=(N1-1)*(N2-1) NGPS=N1*N2*N3 OLEG=NGPS*2+1 NLEG1=(N1-1)*N2*N3 NLEG2=N1*(N2-1)*N3 NLEG3=N1*N2*(N3-1) NLEG12=NLEG1+NLEG2 NLEG =NLEG12+NLEG3 OFAC=OLEG+NLEG+1 NFAC1=N1*(N2-1)*(N3-1) NFAC2=(N1-1)*N2*(N3-1) NFAC3=(N1-1)*(N2-1)*N3 NFAC12=NFAC1+NFAC2 NFAC=NFAC12+NFAC3 NCUB=(N1-1)*(N2-1)*(N3-1) OPOI=OFAC+NFAC NPOI=OPOI IF (NPOI.GT.MRAM) CALL MSEROR(1) C DO 10, I1=1,OPOI IRAM(I1)=0 10 CONTINUE C C C Loop along all gridpoints, recording indices of blocks: WRITE(*,'(A)') *'+MODSRF: Computing indices of blocks.' DO 13, I3=1,N3 DO 12, I2=1,N2 DO 11, I1=1,N1 IX=(I3-1)*N1N2+(I2-1)*N1+I1 IX=2*(IX-1) X1=O1+FLOAT(I1-1)*D1 X2=O2+FLOAT(I2-1)*D2 X3=O3+FLOAT(I3-1)*D3 CALL BLOCK(XX,0,0,ISRF,ISBNEW,ICBNEW) IRAM(IX+1)=ISBNEW IRAM(IX+2)=ICBNEW 11 CONTINUE 12 CONTINUE 13 CONTINUE C C C Loop along all gridlegs, C searching for intersections with structural interfaces: WRITE(*,'(A)') *'+MODSRF: Computing intersections along gridlegs.' C Address of intersection points on gridleg 0: IRAM(OLEG)=NPOI C Index of coordinate in the direction of gridlegs: I4=1 C Auxiliary quantities: DOLD(1)=1. DOLD(2)=0. DOLD(3)=0. DNEW(1)=1. DNEW(2)=0. DNEW(3)=0. DTMP(1)=1. DTMP(2)=0. DTMP(3)=0. DO 29, I1=1,NLEG IF (I1.EQ.NLEG1+1) THEN I4=2 DOLD(1)=0. DOLD(2)=1. DNEW(1)=0. DNEW(2)=1. DTMP(1)=0. DTMP(2)=1. ENDIF IF (I1.EQ.NLEG12+1) THEN I4=3 DOLD(2)=0. DOLD(3)=1. DNEW(2)=0. DNEW(3)=1. DTMP(2)=0. DTMP(3)=1. ENDIF CALL MSGLEG(I1,IP1,IP2) ISBOLD=IRAM(2*(IP1-1)+1) ISBNEW=IRAM(2*(IP2-1)+1) IF (ISBOLD.NE.ISBNEW) THEN C The points of the gridleg are in different simple blocks: ICBOLD=IRAM(2*(IP1-1)+2) ICBNEW=IRAM(2*(IP2-1)+2) CALL MSCP(IP1,XOLD(1),XOLD(2),XOLD(3)) CALL MSCP(IP2,XNEW(1),XNEW(2),XNEW(3)) XTMP(1)=XNEW(1) XTMP(2)=XNEW(2) XTMP(3)=XNEW(3) C Loop for intersection points along the gridleg: ITER=0 21 CONTINUE ITER=ITER+1 IF (ITER.GT.100) THEN C MODSRF-04 CALL ERROR ('MODSRF-04: More than 100 intersections.') C More than 100 points of intersection of the C gridline element with the structural interfaces. C Check the input data and then contact the author. ENDIF C C Determining the interface between points XOLD, XNEW: IY(4)=ISBOLD IY(5)=ICBOLD IY(6)=0 XTMP(I4)=XNEW(I4) XOLD1=XOLD(I4) XNEW1=XNEW(I4) XTMP1=XNEW1 CALL CDE(0,0,IDUMMY,0,IDUMMY,DUMMY,1,3,3,IY,ERRSRF, * XOLD1,XOLD1,XOLD,DOLD,XNEW1,XNEW,DNEW, * XTMP1,XTMP,DTMP,XINT1,XINT,DINT) DO 23, I5=1,3 IF (I5.NE.I4) THEN XTMP(I5)=XOLD(I5) XINT(I5)=XOLD(I5) ENDIF 23 CONTINUE IF ((ICBOLD.NE.ICBNEW).AND.(IY(6).EQ.0)) THEN C The interface was not found between the points with C different ICB. This may happen when the NEW point is C situated directly at the interface. C Repeating the search in reverse direction: DOLD(I4)=-DOLD(I4) DNEW(I4)=-DNEW(I4) DTMP(I4)=-DTMP(I4) XTMP1=XOLD1 XTMP(1)=XOLD(1) XTMP(2)=XOLD(2) XTMP(3)=XOLD(3) IY(4)=ISBNEW IY(5)=ICBNEW CALL CDE(0,0,IDUMMY,0,IDUMMY,DUMMY,1,3,3,IY,ERRSRF, * (XTMP1-ERRSRF),XNEW1,XNEW,DNEW,XOLD1,XOLD,DOLD, * XTMP1,XTMP,DTMP,XINT1,XINT,DINT) DO 25, I5=1,3 IF (I5.NE.I4) THEN XTMP(I5)=XOLD(I5) XINT(I5)=XOLD(I5) ENDIF 25 CONTINUE IF (IY(6).EQ.0) THEN C The interface was not found even in reverse direction. C This may happen when the whole gridleg coincides with an C interface: CALL BLOCK(XOLD,0,ISBOLD,IDUMMY,IB,IDUMMY) IF (IB.NE.ISBOLD) CALL MSEROR(8) CALL BLOCK(XOLD,0,ISBNEW,IDUMMY,IB,IDUMMY) IF (IB.NE.ISBNEW) CALL MSEROR(8) CALL BLOCK(XNEW,0,ISBNEW,IDUMMY,IB,IDUMMY) IF (IB.NE.ISBNEW) CALL MSEROR(8) CALL BLOCK(XNEW,0,ISBOLD,IDUMMY,IB,IDUMMY) IF (IB.NE.ISBOLD) CALL MSEROR(8) C Whole gridleg coincides with an interface: CALL SEPAR(ISBNEW,ISBOLD,IDUMMY,IY(6)) IF (IDUMMY(1).LT.1) CALL MSEROR(8) IY(7)=ISBOLD IY(8)=ICBOLD ENDIF IF (IY(8).NE.ICBOLD) THEN C There should be only one interface between the points. C C MODSRF-06 CALL ERROR('MODSRF-06: More than one interface.') C This error should not appear. Contact the author. ENDIF C Reverting the points to the original order: DOLD(I4)=-DOLD(I4) DNEW(I4)=-DNEW(I4) DTMP(I4)=-DTMP(I4) XTMP1=XNEW1 XTMP(1)=XNEW(1) XTMP(2)=XNEW(2) XTMP(3)=XNEW(3) ISBOLD=IY(7) ICBOLD=IY(8) ISBNEW=IY(4) ICBNEW=IY(5) IY(4)=ISBOLD IY(5)=ICBOLD IY(6)=-IY(6) IY(7)=ISBNEW IY(8)=ICBNEW ENDIF IF (IY(6).NE.0) THEN C Structural interface, recording the point of intersection: C XTMP and XINT are the points of intersection with the C interface, IY(4) and IY(5) are the indices of the simple C block and the complex block before the interface, C IY(6) is the index of the interface, IY(7) and IY(8) are C the indices of the simple block and the complex block C behind the interface: IF (.NOT.MSLPIL(XTMP,I1)) THEN C MODSRF-07 CALL ERROR('MODSRF-07: Point not on the gridleg.') C This error should not appear. Contact the author. ENDIF IF (NPOI+NQPOI.GT.MRAM) CALL MSEROR(1) RAM(NPOI+1)=XTMP(1) RAM(NPOI+2)=XTMP(2) RAM(NPOI+3)=XTMP(3) IRAM(NPOI+4)=IY(5) IRAM(NPOI+5)=IY(4) IRAM(NPOI+6)=IY(6) IRAM(NPOI+7)=IY(7) IRAM(NPOI+8)=IY(8) NPOI=NPOI+NQPOI IF (IY(7).NE.ISBNEW) THEN C IY(7) is the index of simple block behind the interface, C the search for intersection points must continue. C Shifting point XOLD to the point of intersection: XOLD(I4)=XTMP(I4) XOLD1=XOLD(I4) ISBOLD=IY(7) ICBOLD=IY(8) GOTO 21 ENDIF ENDIF C End of the loop for intersection points along the gridleg. ENDIF IRAM(OLEG+I1)=NPOI 29 CONTINUE NPOIL=NPOI C C C Loop along all gridfaces, C connecting the points of intersection of structural interfaces C with gridlegs, if necessary computing points of intersection C of structural edges with gridfaces. WRITE(*,'(A)') *'+MODSRF: Connecting points along gridfaces. ' IF (NCUB.NE.0) THEN OCON=NPOI+(NPOI-OPOI)/2 ELSE OCON=NPOI + (NPOI-OPOI)*3 + NGPS*NQPOI ENDIF NCON=OCON IF (NCON.GT.MRAM) CALL MSEROR(1) C Initialization for RKGS: PRMT(1)=0. PRMT(2)=(D1+D2+D3) PRMT(3)=ERRSRF PRMT(4)=ERRSRF DTMP(1)=1./3. DTMP(2)=DTMP(1) DTMP(3)=DTMP(1) C Address of connections on gridface 0: IRAM(OFAC)=NCON DO 49, I1=1,NFAC C Indices of gridlegs of the gridface: CALL MSGFAC(I1,IL1,IL2,IL3,IL4) C C Forming array with intersection points for the gridface: NJPT=0 DO 31, I2=IRAM(OLEG+IL1-1),IRAM(OLEG+IL1)-NQPOI,NQPOI C I2 points to the start of records for intersection point. NJPT=NJPT+1 IF (NJPT.GT.MJPT) CALL MSEROR(2) JPT(1,NJPT)=I2+NQPOI JPT(2,NJPT)=IRAM(I2+4) JPT(3,NJPT)=IRAM(I2+5) JPT(4,NJPT)=IRAM(I2+6) JPT(5,NJPT)=IRAM(I2+7) JPT(6,NJPT)=IRAM(I2+8) 31 CONTINUE DO 32, I2=IRAM(OLEG+IL2-1),IRAM(OLEG+IL2)-NQPOI,NQPOI C I2 points to the start of records for intersection point. NJPT=NJPT+1 IF (NJPT.GT.MJPT) CALL MSEROR(2) JPT(1,NJPT)=I2+NQPOI JPT(2,NJPT)=IRAM(I2+4) JPT(3,NJPT)=IRAM(I2+5) JPT(4,NJPT)=IRAM(I2+6) JPT(5,NJPT)=IRAM(I2+7) JPT(6,NJPT)=IRAM(I2+8) 32 CONTINUE DO 33, I2=IRAM(OLEG+IL3)-NQPOI,IRAM(OLEG+IL3-1),-NQPOI C I2 points to the start of records for intersection point. NJPT=NJPT+1 IF (NJPT.GT.MJPT) CALL MSEROR(2) JPT(1,NJPT)=-(I2+NQPOI) JPT(2,NJPT)=IRAM(I2+8) JPT(3,NJPT)=IRAM(I2+7) JPT(4,NJPT)=-IRAM(I2+6) JPT(5,NJPT)=IRAM(I2+5) JPT(6,NJPT)=IRAM(I2+4) 33 CONTINUE DO 34, I2=IRAM(OLEG+IL4)-NQPOI,IRAM(OLEG+IL4-1),-NQPOI C I2 points to the start of records for intersection point. NJPT=NJPT+1 IF (NJPT.GT.MJPT) CALL MSEROR(2) JPT(1,NJPT)=-(I2+NQPOI) JPT(2,NJPT)=IRAM(I2+8) JPT(3,NJPT)=IRAM(I2+7) JPT(4,NJPT)=-IRAM(I2+6) JPT(5,NJPT)=IRAM(I2+5) JPT(6,NJPT)=IRAM(I2+4) 34 CONTINUE C C Making connections between points of the gridface: DO 46, I2=1,NJPT DO 36, I3=I2+1,NJPT IF ((JPT(2,I2).EQ.JPT(6,I3)).AND. * (JPT(6,I2).EQ.JPT(2,I3))) THEN C Same indices of complex blocks: IF ((JPT(3,I2).EQ.JPT(5,I3)).AND. * (JPT(5,I2).EQ.JPT(3,I3))) THEN C Same indices of simple blocks: IF (IABS(JPT(4,I2)).EQ.IABS(JPT(4,I3))) THEN C Same interface - connection found: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (JPT(4,I2).LT.0) THEN IRAM(NCON+1)=IABS(JPT(1,I2)) IRAM(NCON+2)=IABS(JPT(1,I3)) IRAM(NCON+3)=JPT(4,I2) NCON=NCON+3 ELSE IRAM(NCON+1)=IABS(JPT(1,I3)) IRAM(NCON+2)=IABS(JPT(1,I2)) IRAM(NCON+3)=JPT(4,I3) NCON=NCON+3 ENDIF GOTO 45 ENDIF ENDIF ENDIF 36 CONTINUE DO 37, I3=IRAM(OFAC+I1-1),NCON-3,3 IF ((IRAM(I3+1).EQ.IABS(JPT(1,I2))).OR. * (IRAM(I3+2).EQ.IABS(JPT(1,I2)))) C The point I2 is already connected: * GOTO 45 37 CONTINUE C Point I2 is not connected, looking for point of intersection C of structural edges with gridface. (Following the intersection C of the interface with the gridface to the edge.) IFACE=I1 IPTE(1)=JPT(1,I2) NIPTE=1 C Loop for identification of all edges connected with point I2: 39 CONTINUE C Initiating the search for the edge: I3=IABS(IPTE(NIPTE))-NQPOI X1= RAM(I3+1) X2= RAM(I3+2) X3= RAM(I3+3) IF (IPTE(NIPTE).LT.0) THEN ICBO1=IRAM(I3+8) ISBO1=IRAM(I3+7) ISRFO=-IRAM(I3+6) ISBO2=IRAM(I3+5) ICBO2=IRAM(I3+4) ELSE ICBO1=IRAM(I3+4) ISBO1=IRAM(I3+5) ISRFO=IRAM(I3+6) ISBO2=IRAM(I3+7) ICBO2=IRAM(I3+8) ENDIF NIPTE=NIPTE-1 C Computing the point of intersection of the edge C with the gridface: CALL RKGS(PRMT,XX,DTMP,3,I7,FCTMS,OUTMS,AUX) IF (PRMT(5).EQ.2.) THEN C An intersection point was not found within the gridface. C This may happen e.g. when the interface is crossed by C the interface, which separates two (four) simple blocks C of the same complex block(s). I3=I3+NQPOI C Looking for the connection along the given interface: DO 394, I4=1,NJPT IF ((ICBO2.EQ.JPT(2,I4)).AND. * (ICBO1.EQ.JPT(6,I4)).AND. * (IABS(ISRFO).EQ.IABS(JPT(4,I4)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (JPT(4,I4).LT.0) THEN IRAM(NCON+1)=IABS(JPT(1,I4)) IRAM(NCON+2)=I3 IRAM(NCON+3)=JPT(4,I4) ELSE IRAM(NCON+1)=I3 IRAM(NCON+2)=IABS(JPT(1,I4)) IRAM(NCON+3)=-JPT(4,I4) ENDIF NCON=NCON+3 GOTO 398 ENDIF 394 CONTINUE C MODSRF-09 CALL ERROR('MODSRF-09: Point cannot be connected.') C An intersection point was not found within the gridface, C and the point cannot be connected with the points on C the gridlegs. C This error should not appear. Contact the author. 398 CONTINUE ELSEIF (PRMT(5).EQ.1.) THEN C The intersection point was found by RKGS. C Storing the first point on the edge: IF (NPOI+NQPOI.GT.OCON) CALL MSEROR(1) RAM(NPOI+1)=X1 RAM(NPOI+2)=X2 RAM(NPOI+3)=X3 IRAM(NPOI+4)=ICBO1 IRAM(NPOI+5)=ISBO1 IRAM(NPOI+6)=ISRFO IRAM(NPOI+7)=ISBO2 IRAM(NPOI+8)=ICBO2 NPOI=NPOI+NQPOI J1=NPOI C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (ISRFO.LT.0) THEN IRAM(NCON+1)=IABS(IPTE(NIPTE+1)) IRAM(NCON+2)=NPOI IRAM(NCON+3)=ISRFO ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=IABS(IPTE(NIPTE+1)) IRAM(NCON+3)=-ISRFO ENDIF NCON=NCON+3 C IF (ICBO1.NE.ICBN1) THEN C Storing the second point on the edge: IF (NPOI+NQPOI.GT.OCON) CALL MSEROR(1) RAM(NPOI+1)=X1 RAM(NPOI+2)=X2 RAM(NPOI+3)=X3 IRAM(NPOI+4)=ICBN1 IRAM(NPOI+5)=ISBN1 IRAM(NPOI+6)=-ISRFN1 IRAM(NPOI+7)=ISBO1 IRAM(NPOI+8)=ICBO1 NPOI=NPOI+NQPOI IF (NCUB.EQ.0) THEN C 'Connection' between first and second point on C the edge: IF (NCON+3.GT.MRAM) CALL MSEROR(1) J2=NPOI-NQPOI IF (IRAM(J2-NQPOI+6).LT.0) J2=-J2 J3=NPOI IF (IRAM(J3-NQPOI+6).GT.0) J3=-J3 IRAM(NCON+1)=J2 IRAM(NCON+2)=J3 IRAM(NCON+3)=0 NCON=NCON+3 ENDIF DO 40, I3=1,NJPT IF ((ICBN1.EQ.JPT(2,I3)).AND. * (ISBN1.EQ.JPT(3,I3)).AND. * (ISBO1.EQ.JPT(5,I3)).AND. * (ICBO1.EQ.JPT(6,I3)).AND. * (IABS(ISRFN1).EQ.IABS(JPT(4,I3)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (JPT(4,I3).LT.0) THEN IRAM(NCON+1)=IABS(JPT(1,I3)) IRAM(NCON+2)=NPOI IRAM(NCON+3)=JPT(4,I3) ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=IABS(JPT(1,I3)) IRAM(NCON+3)=-JPT(4,I3) ENDIF NCON=NCON+3 GOTO 405 ENDIF 40 CONTINUE DO 401, I3=1,NIPTE I4=IABS(IPTE(I3))-NQPOI IF ((ICBN1.EQ.IRAM(I4+8)).AND. * (ISBN1.EQ.IRAM(I4+7)).AND. * (ISBO1.EQ.IRAM(I4+5)).AND. * (ICBO1.EQ.IRAM(I4+4)).AND. * (IABS(ISRFN1).EQ.IABS(IRAM(I4+6)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (IRAM(I4+6).LT.0) THEN IRAM(NCON+1)=I4+NQPOI IRAM(NCON+2)=NPOI IRAM(NCON+3)=IRAM(I4+6) ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=I4+NQPOI IRAM(NCON+3)=-IRAM(I4+6) ENDIF NCON=NCON+3 GOTO 405 ENDIF 401 CONTINUE C More than one edge, current point will become a starting C point of the search for new edge: NIPTE=NIPTE+1 IF (NIPTE.GT.MIPTE) CALL MSEROR(3) IPTE(NIPTE)=-NPOI 405 CONTINUE ENDIF C IF (ICBN2.NE.ICBN1) THEN C Storing the third point on the edge: IF (NPOI+NQPOI.GT.OCON) CALL MSEROR(1) RAM(NPOI+1)=X1 RAM(NPOI+2)=X2 RAM(NPOI+3)=X3 IRAM(NPOI+4)=ICBN2 IRAM(NPOI+5)=ISBN2 IRAM(NPOI+6)=-ISRFO IRAM(NPOI+7)=ISBN1 IRAM(NPOI+8)=ICBN1 NPOI=NPOI+NQPOI IF (NCUB.EQ.0) THEN C 'Connection' between second and third point on C the edge: IF (NCON+3.GT.MRAM) CALL MSEROR(1) J2=NPOI-NQPOI IF (IRAM(J2-NQPOI+6).LT.0) J2=-J2 J3=NPOI IF (IRAM(J3-NQPOI+6).GT.0) J3=-J3 IRAM(NCON+1)=J2 IRAM(NCON+2)=J3 IRAM(NCON+3)=0 NCON=NCON+3 ENDIF DO 42, I3=1,NJPT IF ((ICBN2.EQ.JPT(2,I3)).AND. * (ISBN2.EQ.JPT(3,I3)).AND. * (ISBN1.EQ.JPT(5,I3)).AND. * (ICBN1.EQ.JPT(6,I3)).AND. * (IABS(ISRFO).EQ.IABS(JPT(4,I3)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (JPT(4,I3).LT.0) THEN IRAM(NCON+1)=IABS(JPT(1,I3)) IRAM(NCON+2)=NPOI IRAM(NCON+3)=JPT(4,I3) ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=IABS(JPT(1,I3)) IRAM(NCON+3)=-JPT(4,I3) ENDIF NCON=NCON+3 GOTO 425 ENDIF 42 CONTINUE DO 421, I3=1,NIPTE I4=IABS(IPTE(I3))-NQPOI IF ((ICBN2.EQ.IRAM(I4+8)).AND. * (ISBN2.EQ.IRAM(I4+7)).AND. * (ISBN1.EQ.IRAM(I4+5)).AND. * (ICBN1.EQ.IRAM(I4+4)).AND. * (IABS(ISRFO).EQ.IABS(IRAM(I4+6)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (IRAM(I4+6).LT.0) THEN IRAM(NCON+1)=I4+NQPOI IRAM(NCON+2)=NPOI IRAM(NCON+3)=IRAM(I4+6) ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=I4+NQPOI IRAM(NCON+3)=-IRAM(I4+6) ENDIF NCON=NCON+3 GOTO 425 ENDIF 421 CONTINUE C More than one edge, current point will become a starting C point of the search for new edge: NIPTE=NIPTE+1 IF (NIPTE.GT.MIPTE) CALL MSEROR(3) IPTE(NIPTE)=-NPOI 425 CONTINUE ENDIF C IF (ICBO2.NE.ICBN2) THEN C Storing the fourth point on the edge: IF (NPOI+NQPOI.GT.OCON) CALL MSEROR(1) RAM(NPOI+1)=X1 RAM(NPOI+2)=X2 RAM(NPOI+3)=X3 IRAM(NPOI+4)=ICBO2 IRAM(NPOI+5)=ISBO2 IRAM(NPOI+6)=ISRFN2 IRAM(NPOI+7)=ISBN2 IRAM(NPOI+8)=ICBN2 NPOI=NPOI+NQPOI IF (NCUB.EQ.0) THEN C 'Connection' between third and fourth point on C the edge: IF (NCON+3.GT.MRAM) CALL MSEROR(1) J2=NPOI-NQPOI IF (IRAM(J2-NQPOI+6).LT.0) J2=-J2 J3=NPOI IF (IRAM(J3-NQPOI+6).GT.0) J3=-J3 IRAM(NCON+1)=J2 IRAM(NCON+2)=J3 IRAM(NCON+3)=0 NCON=NCON+3 ENDIF DO 41, I3=1,NJPT IF ((ICBO2.EQ.JPT(2,I3)).AND. * (ISBO2.EQ.JPT(3,I3)).AND. * (ISBN2.EQ.JPT(5,I3)).AND. * (ICBN2.EQ.JPT(6,I3)).AND. * (IABS(ISRFN2).EQ.IABS(JPT(4,I3)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (JPT(4,I3).LT.0) THEN IRAM(NCON+1)=IABS(JPT(1,I3)) IRAM(NCON+2)=NPOI IRAM(NCON+3)=JPT(4,I3) ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=IABS(JPT(1,I3)) IRAM(NCON+3)=-JPT(4,I3) ENDIF NCON=NCON+3 GOTO 415 ENDIF 41 CONTINUE DO 411, I3=1,NIPTE I4=IABS(IPTE(I3))-NQPOI IF ((ICBO2.EQ.IRAM(I4+8)).AND. * (ISBO2.EQ.IRAM(I4+7)).AND. * (ISBN2.EQ.IRAM(I4+5)).AND. * (ICBN2.EQ.IRAM(I4+4)).AND. * (IABS(ISRFN2).EQ.IABS(IRAM(I4+6)))) THEN C Recording the connection: IF (NCON+3.GT.MRAM) CALL MSEROR(1) IF (IRAM(I4+6).LT.0) THEN IRAM(NCON+1)=I4+NQPOI IRAM(NCON+2)=NPOI IRAM(NCON+3)=IRAM(I4+6) ELSE IRAM(NCON+1)=NPOI IRAM(NCON+2)=I4+NQPOI IRAM(NCON+3)=-IRAM(I4+6) ENDIF NCON=NCON+3 GOTO 415 ENDIF 411 CONTINUE C More than one edge, current point will become a starting C point of the search for new edge: NIPTE=NIPTE+1 IF (NIPTE.GT.MIPTE) CALL MSEROR(3) IPTE(NIPTE)=-NPOI 415 CONTINUE ENDIF C IF (NCUB.EQ.0) THEN C 'Connection' between fourth and first point on the edge: IF (NCON+3.GT.MRAM) CALL MSEROR(1) J2=NPOI IF (IRAM(J2-NQPOI+6).LT.0) J2=-J2 J3=J1 IF (IRAM(J3-NQPOI+6).GT.0) J3=-J3 IRAM(NCON+1)=J2 IRAM(NCON+2)=J3 IRAM(NCON+3)=0 NCON=NCON+3 ENDIF ELSE C MODSRF-08 CALL ERROR('MODSRF-08: Wrong value of PRMT(5).') C PRMT(5) should equal either 1. or 2. after RKGS is called. C This error should not appear. Contact the author. ENDIF IF (NIPTE.GE.1) C Continuing with the search for next edge: * GOTO 39 C End of the loop for identification of all edges connected with C point I2. C C No more edges, the point is connected. 45 CONTINUE C Continuing with next point of the gridface: 46 CONTINUE IRAM(OFAC+I1)=NCON 49 CONTINUE NPOIE=NPOI C C IF (NCUB.NE.0) THEN C Loop along all gridcubes, C merging the connections between the points on structural C interfaces into polygons approximating the interfaces. WRITE(*,'(A)') *'+MODSRF: Making polygons approximating the interfaces.' NPOL=MRAM+1 DO 100, I1=1,NCUB C Indices of gridfaces of the gridcube: CALL MSGCUB(I1,IF1,IF2,IF3,IF4,IF5,IF6) C C Forming array with connections for the gridcube: NJCN=0 NNJCN(0)=NJCN DO 51, I2=IRAM(OFAC+IF1-1),IRAM(OFAC+IF1)-3,3 C Connections of the gridface IF1: NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+1) JCN(2,NJCN)=IRAM(I2+2) JCN(3,NJCN)=IRAM(I2+3) JCN(4,NJCN)=0 51 CONTINUE NNJCN(1)=NJCN DO 52, I2=IRAM(OFAC+IF2-1),IRAM(OFAC+IF2)-3,3 C Connections of the gridface IF2: NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+1) JCN(2,NJCN)=IRAM(I2+2) JCN(3,NJCN)=IRAM(I2+3) JCN(4,NJCN)=0 52 CONTINUE NNJCN(2)=NJCN DO 53, I2=IRAM(OFAC+IF3-1),IRAM(OFAC+IF3)-3,3 C Connections of the gridface IF3: NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+1) JCN(2,NJCN)=IRAM(I2+2) JCN(3,NJCN)=IRAM(I2+3) JCN(4,NJCN)=0 53 CONTINUE NNJCN(3)=NJCN DO 54, I2=IRAM(OFAC+IF4-1),IRAM(OFAC+IF4)-3,3 C Connections of the gridface IF4: NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+2) JCN(2,NJCN)=IRAM(I2+1) JCN(3,NJCN)=IRAM(I2+3) JCN(4,NJCN)=0 54 CONTINUE NNJCN(4)=NJCN DO 55, I2=IRAM(OFAC+IF5-1),IRAM(OFAC+IF5)-3,3 C Connections of the gridface IF5: NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+2) JCN(2,NJCN)=IRAM(I2+1) JCN(3,NJCN)=IRAM(I2+3) JCN(4,NJCN)=0 55 CONTINUE NNJCN(5)=NJCN DO 56, I2=IRAM(OFAC+IF6-1),IRAM(OFAC+IF6)-3,3 C Connections of the gridface IF6: NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+2) JCN(2,NJCN)=IRAM(I2+1) JCN(3,NJCN)=IRAM(I2+3) JCN(4,NJCN)=0 56 CONTINUE NNJCN(6)=NJCN DO 58, I2=1,NNJCN(6) C Connections between points on edges: IF (JCN(2,I2).GT.NPOIL) THEN ICBO1=IRAM(JCN(2,I2)-NQPOI+4) ICBO2=IRAM(JCN(2,I2)-NQPOI+8) LCN=.FALSE. DO 57, I3=1,NNJCN(6) IF (I3.NE.I2) THEN IF ((JCN(1,I3).GT.NPOIL).AND. * (IABS(JCN(3,I2)).EQ.IABS(JCN(3,I3)))) THEN ICBN1=IRAM(JCN(1,I3)-NQPOI+4) ICBN2=IRAM(JCN(1,I3)-NQPOI+8) IF (((ICBO1.EQ.ICBN1).AND.(ICBO2.EQ.ICBN2)).OR. * ((ICBO2.EQ.ICBN1).AND.(ICBO1.EQ.ICBN2))) THEN NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=JCN(2,I2) JCN(2,NJCN)=JCN(1,I3) JCN(3,NJCN)=JCN(3,I3) JCN(4,NJCN)=0 LCN=.TRUE. ENDIF ENDIF ENDIF 57 CONTINUE IF (.NOT.LCN) THEN C Connection for edge not found, this connection is to be C canceled by means of creation of linear 'triangle': NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=JCN(2,I2) JCN(2,NJCN)=JCN(1,I2) JCN(3,NJCN)=JCN(3,I2) JCN(4,NJCN)=0 ENDIF ENDIF 58 CONTINUE NNJCN(7)=NJCN C C Looking for polygons on the faces of the cube. NJPOL=0 C Loop for faces of the cube: DO 70, I2=1,6 C Initiating indices of connections: DO 61, I3=1,MJCN IND(I3)=0 61 CONTINUE NIND=NNJCN(I2)-NNJCN(I2-1) C Loop along connections: I3=1 62 CONTINUE IF (NJPOL+1.GT.MJPOL) CALL MSEROR(6) C Search for first unused connection: IF (I3.LE.NIND-2) THEN IF (IND(I3).GE.0) THEN C Unused connection, recording first two points C of the polygon: NLJPOL=2 JPOL(1,NJPOL+1)=JCN(1,NNJCN(I2-1)+I3) JPOL(2,NJPOL+1)=JCN(2,NNJCN(I2-1)+I3) IND(I3)=-1 ELSE I3=I3+1 GOTO 62 ENDIF C Search for next point of polygon: 63 CONTINUE DO 69, I4=I3+1,NIND IF ( JCN(1,NNJCN(I2-1)+I4) .EQ. * JPOL(NLJPOL,NJPOL+1) ) THEN C Recording next point of polygon: NLJPOL=NLJPOL+1 IF (NLJPOL.GT.MLJPOL) CALL MSEROR(7) JPOL(NLJPOL,NJPOL+1)=JCN(2,NNJCN(I2-1)+I4) IND(I4)=-1 DO 68, I5=NLJPOL-3,1,-1 C Examining whether the polygon is closed: IF (JPOL(I5,NJPOL+1).EQ.JPOL(NLJPOL,NJPOL+1)) THEN C Polygon is closed. C Recording the polygon: NJPOL=NJPOL+1 NLJPOL=NLJPOL-I5 JPOL(0,NJPOL)=NLJPOL DO 65, I6=1,NLJPOL JPOL(I6,NJPOL)=JPOL(I5+I6,NJPOL) 65 CONTINUE C Removing used starting points: DO 67, I6=1,NLJPOL IF (I6.EQ.1) THEN J1=JPOL(NLJPOL,NJPOL) ELSE J1=JPOL(I6-1,NJPOL) ENDIF J2=JPOL(I6,NJPOL) IF (I6.EQ.NJPOL) THEN J3=JPOL(1,NJPOL) ELSE J3=JPOL(I6+1,NJPOL) ENDIF 67 CONTINUE C Continuing with next polygon: GOTO 62 ENDIF 68 CONTINUE GOTO 63 ENDIF 69 CONTINUE C Polygon is opened, searching for other polygon: GOTO 62 ENDIF C No more unused connections, C no more polygons on this face of the cube. C End of the loop along connections. 70 CONTINUE C C Two or more polygons on the faces of the cube: IF (NJPOL.GE.2) THEN C MODSRF-10 CALL ERROR('MODSRF-10: Two or more polygons on gridface.') C This situation cannot be handled by current version of C MODSRF. Try to reduce the gridstep (D1,D2,D3). ENDIF C C If there is one polygon on the faces of the cube, C the polygon is to be recorded as a polygon approximating C a structural interface: IF (NJPOL.EQ.1) THEN C Searching, whether the polygon is to be recorded: C Loop for already recorded polygons: I2=MRAM+1 73 CONTINUE IF (I2.GT.NPOL) THEN J1=IRAM(I2-1) I2=I2-J1-1 IF (J1.EQ.JPOL(0,1)) THEN DO 74, I3=1,J1 IF (IRAM(I2+I3).NE.JPOL(I3,1)) GOTO 73 74 CONTINUE C The polygon is already recorded: GOTO 77 ELSE GOTO 73 ENDIF ENDIF C End of the loop for already recorded polygons. C Recording the polygon: IF (NPOL-JPOL(0,1)-1.LE.NCON) CALL MSEROR(1) NPOL=NPOL-1 IRAM(NPOL)=JPOL(0,1) DO 75, I2=1,JPOL(0,1) NPOL=NPOL-1 IRAM(NPOL)=JPOL(I2,1) 75 CONTINUE 77 CONTINUE ENDIF C C Recording polygons approximating structural interfaces: C Marking wrong and sure connections: CALL MSJCN(JCN,NJCN,MJCN) C C Recording the polygons: NJPOL=0 80 CONTINUE C Loop for adding new polygons C Initializing a polygon: DO 81, I2=1,NJCN IF (JCN(4,I2).EQ.1) THEN NJPOL=NJPOL+1 IF (NJPOL.GT.MJPOL) CALL MSEROR(6) NLJPOL=2 JPOL(0,NJPOL)=0 JPOL(1,NJPOL)=JCN(1,I2) JPOL(2,NJPOL)=JCN(2,I2) JCN(4,I2)=-2 GOTO 83 ENDIF 81 CONTINUE C No other point to initialize a polygon: GOTO 97 C 83 CONTINUE C Loop for adding points to the polygon: C C Removing connections, which would cause overlooping C of the polygon in the current position: DO 87, I2=1,NJCN IF (JCN(4,I2).EQ.0) THEN IF (JCN(1,I2).EQ.JPOL(NLJPOL,NJPOL)) THEN DO 84, I3=2,NLJPOL IF (JCN(2,I2).EQ.JPOL(I3,NJPOL)) THEN C This connection would cause overlooping C of the end of the polygon: JCN(4,I2)=-1 CALL MSJCN(JCN,NJCN,MJCN) GOTO 86 ENDIF 84 CONTINUE ELSEIF (JCN(2,I2).EQ.JPOL(1,NJPOL)) THEN DO 85, I3=2,NLJPOL IF (JCN(1,I2).EQ.JPOL(I3,NJPOL)) THEN C This connection would cause overlooping C of the beginning of the polygon: JCN(4,I2)=-1 CALL MSJCN(JCN,NJCN,MJCN) GOTO 86 ENDIF 85 CONTINUE ENDIF ENDIF 86 CONTINUE 87 CONTINUE C C Looking for the point, which might be added C to the polygon in the current position: DO 92, I2=1,NJCN C Trying to add a point to the end of the polygon: IF ((JCN(1,I2).EQ.JPOL(NLJPOL,NJPOL)).AND. * (JCN(4,I2).EQ.1)) THEN C Point I2 may be added to the polygon. IF (JCN(2,I2).EQ.JPOL(1,NJPOL)) THEN C This point closes the polygon: JPOL(0,NJPOL)=NLJPOL JCN(4,I2)=-2 GOTO 80 ELSE C Adding a point to the polygon: NLJPOL=NLJPOL+1 IF (NLJPOL.GT.MLJPOL) CALL MSEROR(7) JPOL(NLJPOL,NJPOL)=JCN(2,I2) JCN(4,I2)=-2 GOTO 83 ENDIF ENDIF 92 CONTINUE DO 94, I2=1,NJCN C Trying to add a point to the beginning of the polygon: IF ((JCN(2,I2).EQ.JPOL(1,NJPOL)).AND. * (JCN(4,I2).EQ.1)) THEN C Point I2 may be added to the polygon. IF (JCN(1,I2).EQ.JPOL(NLJPOL,NJPOL)) THEN C This point closes the polygon: JPOL(0,NJPOL)=NLJPOL JCN(4,I2)=-2 GOTO 80 ELSE C Adding a point to the polygon: NLJPOL=NLJPOL+1 IF (NLJPOL.GT.MLJPOL) CALL MSEROR(7) DO 93, I3=NLJPOL,2,-1 JPOL(I3,NJPOL)=JPOL(I3-1,NJPOL) 93 CONTINUE JPOL(1,NJPOL)=JCN(1,I2) JCN(4,I2)=-2 GOTO 83 ENDIF ENDIF 94 CONTINUE DO 95, I2=1,NJCN C Trying to find and cancel the connection between C the last and the first point of the polygon: IF ((JCN(1,I2).EQ.JPOL(NLJPOL,NJPOL)).AND. * (JCN(2,I2).EQ.JPOL(1,NJPOL)).AND. * (JCN(4,I2).EQ.0)) THEN JCN(4,I2)=-1 CALL MSJCN(JCN,NJCN,MJCN) GOTO 83 ENDIF 95 CONTINUE C MODSRF-14 CALL ERROR ('MODSRF-14: Polygon opened.') C This error should not appear. Contact the author. C End of the loop for adding new points to the polygon. C End of the loop for adding new polygons. C 97 CONTINUE C Writing polygons to IRAM: DO 99, I2=1,NJPOL IF (JPOL(0,I2).GT.2) THEN IF (NPOL-JPOL(0,I2)-1.LE.NCON) CALL MSEROR(1) NPOL=NPOL-1 IRAM(NPOL)=JPOL(0,I2) DO 98, I3=1,JPOL(0,I2) NPOL=NPOL-1 IRAM(NPOL)=JPOL(I3,I2) 98 CONTINUE ENDIF 99 CONTINUE NJPOL=0 C C End of the loop over gridcubes. 100 CONTINUE C C ELSE C Loop over rectangles of the 2-D grid, making polygons along the C 2-D slice through the model. WRITE(*,'(A)') *'+MODSRF: Making polygons along the 2-D slice. ' NPOL=MRAM+1 C C Rewriting points on interfaces as points on + side of interface: ISHIFT=NPOIE-OPOI IF (NPOI+ISHIFT.GT.OCON) CALL MSEROR(1) DO 102, I1=OPOI,NPOIE-NQPOI,NQPOI RAM(NPOI+1)=RAM(I1+1) RAM(NPOI+2)=RAM(I1+2) RAM(NPOI+3)=RAM(I1+3) IF (IRAM(I1+6).LT.0) THEN IRAM(NPOI+4)=IRAM(I1+8) IRAM(NPOI+5)=IRAM(I1+7) IRAM(NPOI+6)=0 IRAM(NPOI+7)=IRAM(I1+7) IRAM(NPOI+8)=IRAM(I1+8) ELSE IRAM(NPOI+4)=IRAM(I1+4) IRAM(NPOI+5)=IRAM(I1+5) IRAM(NPOI+6)=0 IRAM(NPOI+7)=IRAM(I1+5) IRAM(NPOI+8)=IRAM(I1+4) ENDIF NPOI=NPOI+NQPOI 102 CONTINUE NPOILP=NPOIL+ISHIFT NPOIEP=NPOIE+ISHIFT C C Rewriting points on interfaces as points on - side of interface: DO 104, I1=OPOI,NPOIE-NQPOI,NQPOI IF (IRAM(I1+6).LT.0) THEN IRAM(I1+7)=IRAM(I1+5) IRAM(I1+8)=IRAM(I1+4) ELSE IRAM(I1+4)=IRAM(I1+8) IRAM(I1+5)=IRAM(I1+7) ENDIF IRAM(NPOI+6)=0 104 CONTINUE C C Recording gridpoints to the array of points: IF (NPOI+NGPS*NQPOI.GT.OCON) CALL MSEROR(1) DO 106, I1=1,NGPS CALL MSCP(I1,X1,X2,X3) RAM(NPOI+1)=X1 RAM(NPOI+2)=X2 RAM(NPOI+3)=X3 IRAM(NPOI+4)=IRAM(2*(I1-1)+2) IRAM(NPOI+5)=IRAM(2*(I1-1)+1) IRAM(NPOI+6)=0 IRAM(NPOI+7)=IRAM(2*(I1-1)+1) IRAM(NPOI+8)=IRAM(2*(I1-1)+2) NPOI=NPOI+NQPOI 106 CONTINUE C Loop over gridfaces: DO 200, I1=1,NFAC C Forming array with connections for the gridface: NJCN=0 C Connections inside the gridface: DO 110, I2=IRAM(OFAC+I1-1),IRAM(OFAC+I1)-3,3 C Connections of the gridface I1: IF (IRAM(I2+3).NE.0) THEN NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+1) JCN(2,NJCN)=IRAM(I2+2) JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=IRAM(I2+2)+ISHIFT JCN(2,NJCN)=IRAM(I2+1)+ISHIFT JCN(3,NJCN)=1 ELSE NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) IF (IRAM(I2+1).LT.0) THEN JCN(1,NJCN)=-IRAM(I2+1) ELSE JCN(1,NJCN)=IRAM(I2+1)+ISHIFT ENDIF IF (IRAM(I2+2).LT.0) THEN JCN(2,NJCN)=-IRAM(I2+2) ELSE JCN(2,NJCN)=IRAM(I2+2)+ISHIFT ENDIF JCN(3,NJCN)=1 ENDIF 110 CONTINUE C Connections along the gridface: C Indices of gridlegs of the gridface: CALL MSGFAC(I1,IL1,IL2,IL3,IL4) C CALL MSGLEG(IL1,IP1,IP2) NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=NPOIEP+IP1*NQPOI DO 112, I2=IRAM(OLEG+IL1-1)+NQPOI,IRAM(OLEG+IL1),NQPOI ICBOLD=IRAM(JCN(1,NJCN)-NQPOI+4) ICBNEW=IRAM(I2 -NQPOI+4) IF (ICBOLD.NE.ICBNEW) THEN JCN(2,NJCN)=I2+ISHIFT JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2 ELSE JCN(2,NJCN)=I2 JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2+ISHIFT ENDIF 112 CONTINUE JCN(2,NJCN)=NPOIEP+IP2*NQPOI JCN(3,NJCN)=1 C CALL MSGLEG(IL2,IP1,IP2) NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=NPOIEP+IP1*NQPOI DO 114, I2=IRAM(OLEG+IL2-1)+NQPOI,IRAM(OLEG+IL2),NQPOI ICBOLD=IRAM(JCN(1,NJCN)-NQPOI+4) ICBNEW=IRAM(I2 -NQPOI+4) IF (ICBOLD.NE.ICBNEW) THEN JCN(2,NJCN)=I2+ISHIFT JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2 ELSE JCN(2,NJCN)=I2 JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2+ISHIFT ENDIF 114 CONTINUE JCN(2,NJCN)=NPOIEP+IP2*NQPOI JCN(3,NJCN)=1 C CALL MSGLEG(IL3,IP2,IP1) NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=NPOIEP+IP1*NQPOI DO 116, I2=IRAM(OLEG+IL3),IRAM(OLEG+IL3-1)+NQPOI,-NQPOI ICBOLD=IRAM(JCN(1,NJCN)-NQPOI+4) ICBNEW=IRAM(I2 -NQPOI+4) IF (ICBOLD.NE.ICBNEW) THEN JCN(2,NJCN)=I2+ISHIFT JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2 ELSE JCN(2,NJCN)=I2 JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2+ISHIFT ENDIF 116 CONTINUE JCN(2,NJCN)=NPOIEP+IP2*NQPOI JCN(3,NJCN)=1 C CALL MSGLEG(IL4,IP2,IP1) NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=NPOIEP+IP1*NQPOI DO 118, I2=IRAM(OLEG+IL4),IRAM(OLEG+IL4-1)+NQPOI,-NQPOI ICBOLD=IRAM(JCN(1,NJCN)-NQPOI+4) ICBNEW=IRAM(I2 -NQPOI+4) IF (ICBOLD.NE.ICBNEW) THEN JCN(2,NJCN)=I2+ISHIFT JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2 ELSE JCN(2,NJCN)=I2 JCN(3,NJCN)=1 NJCN=NJCN+1 IF (NJCN.GT.MJCN) CALL MSEROR(4) JCN(1,NJCN)=I2+ISHIFT ENDIF 118 CONTINUE JCN(2,NJCN)=NPOIEP+IP2*NQPOI JCN(3,NJCN)=1 C Array with connections is done. C C Forming polygons along the gridface: 124 CONTINUE DO 130, I2=1,NJCN IF (JCN(3,I2).NE.0) THEN C Initiating polygon: NLJPOL=2 JPOL(1,1)=JCN(1,I2) JPOL(2,1)=JCN(2,I2) JCN(3,I2)=0 126 CONTINUE DO 128, I3=1,NJCN IF ((JCN(3,I3).NE.0).AND. * (JCN(1,I3).EQ.JPOL(NLJPOL,1))) THEN NLJPOL=NLJPOL+1 IF (NLJPOL.GT.MLJPOL) CALL MSEROR(7) JPOL(NLJPOL,1)=JCN(2,I3) JCN(3,I3)=0 IF (JPOL(NLJPOL,1).EQ.JPOL(1,1)) THEN C Polygon is closed - recording the polygon to IRAM: NLJPOL=NLJPOL-1 IF (NPOL-NLJPOL-1.LE.NCON) CALL MSEROR(1) NPOL=NPOL-1 IRAM(NPOL)=NLJPOL DO 127, I4=1,NLJPOL NPOL=NPOL-1 IRAM(NPOL)=JPOL(I4,1) 127 CONTINUE GOTO 124 ELSE GOTO 126 ENDIF ENDIF 128 CONTINUE C MODSRF-15 CALL ERROR ('MODSRF-15: Polygon not closed.') C This error should not appear. Contact the author. ENDIF 130 CONTINUE C End of the loop along gridfaces of the 2-D slice. 200 CONTINUE C C Preparing the normal to the 2-D slice: F(2)=0. F(3)=0. F(4)=0. IF (N1.EQ.1) F(2)=1. IF (N2.EQ.1) F(3)=1. IF (N3.EQ.1) F(4)=1. C ENDIF C C C Storing points on structural interfaces and polygons: WRITE(*,'(A)') *'+MODSRF: Writing. ' C C Storing points: OPEN(LU,FILE=VRTX,FORM='FORMATTED') WRITE(LU,'(A)') '/' NPOINT=(NPOI-OPOI)/NQPOI C Length of the names of points: LEN1=LENGTH(TEXTP) LEN2=0 202 CONTINUE IF (NPOINT.GE.10**LEN2) THEN LEN2=LEN2+1 GOTO 202 ENDIF LENG=LEN1+LEN2 C Loop over points: DO 218, I1=1,NPOINT C Address in RAM just before the current point: J1=OPOI+(I1-1)*NQPOI C Name of the point: DO 204, I2=0,LEN2-1 TEXTP(LENG-I2:LENG-I2)= * CHAR(ICHAR('0')+MOD(I1,10**(I2+1))/10**I2) 204 CONTINUE C Preparing the indices of complex blocks: IF (IRAM(J1+6).LT.0) THEN ICBPOS=IRAM(J1+8) ICBNEG=IRAM(J1+4) ELSE ICBPOS=IRAM(J1+4) ICBNEG=IRAM(J1+8) ENDIF C Preparing the normal to the interface at the point: IF (NCUB.NE.0) CALL SRFC2(IRAM(J1+6),RAM(J1+1),F) C The quantities at the point: J2=0 C Loop over the quantities to be stored: 206 CONTINUE IF ((TEXTC(J2+1).NE.' ').AND.(J2+1.LE.69)) THEN J2=J2+1 IF (TEXTC(J2).EQ.'x1') THEN C First coordinate of the point: IF (POWER(J2).EQ.1.) THEN Z(J2)=RAM(J1+1) ELSE Z(J2)=RAM(J1+1)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'x2') THEN C Second coordinate of the point: IF (POWER(J2).EQ.1.) THEN Z(J2)=RAM(J1+2) ELSE Z(J2)=RAM(J1+2)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'x3') THEN C Third coordinate of the point: IF (POWER(J2).EQ.1.) THEN Z(J2)=RAM(J1+3) ELSE Z(J2)=RAM(J1+3)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'norm1') THEN C First component of the normal: IF (POWER(J2).EQ.1.) THEN Z(J2)=F(2) ELSE Z(J2)=F(2)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'norm2') THEN C Second component of the normal: IF (POWER(J2).EQ.1.) THEN Z(J2)=F(3) ELSE Z(J2)=F(3)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'norm3') THEN C Third component of the normal: IF (POWER(J2).EQ.1.) THEN Z(J2)=F(4) ELSE Z(J2)=F(4)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'isrf') THEN Z(J2)=FLOAT(IABS(IRAM(J1+6)))**POWER(J2) ELSEIF (TEXTC(J2).EQ.'+icb') THEN Z(J2)=FLOAT(ICBPOS)**POWER(J2) ELSEIF (TEXTC(J2).EQ.'-icb') THEN Z(J2)=FLOAT(ICBNEG)**POWER(J2) ELSEIF (TEXTC(J2).EQ.'+isb') THEN IF (IRAM(J1+6).LT.0) THEN Z(J2)=FLOAT(IRAM(J1+7))**POWER(J2) ELSE Z(J2)=FLOAT(IRAM(J1+5))**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'-isb') THEN IF (IRAM(J1+6).LT.0) THEN Z(J2)=FLOAT(IRAM(J1+5))**POWER(J2) ELSE Z(J2)=FLOAT(IRAM(J1+7))**POWER(J2) ENDIF ELSEIF ((TEXTC(J2)(2:2).EQ.'v') * .OR.(TEXTC(J2)(2:2).EQ.'d') * .OR.(TEXTC(J2)(2:3).EQ.'qp') * .OR.(TEXTC(J2)(2:3).EQ.'qs')) THEN VP(1)=0. VS(1)=0. RHO=0. QP=0. QS=0. IF (TEXTC(J2)(1:1).EQ.'+') THEN IF (ICBPOS.NE.0) CALL PARM2(ICBPOS,Z(1),VP,VS,RHO,QP,QS) ELSE IF (ICBNEG.NE.0) CALL PARM2(ICBNEG,Z(1),VP,VS,RHO,QP,QS) ENDIF IF (TEXTC(J2)(2:3).EQ.'vp') THEN Z(J2)=VP(1)**POWER(J2) ELSEIF (TEXTC(J2)(2:3).EQ.'vs') THEN Z(J2)=VS(1)**POWER(J2) ELSEIF (TEXTC(J2)(2:3).EQ.'de') THEN Z(J2)=RHO**POWER(J2) ELSEIF (TEXTC(J2)(2:3).EQ.'qp') THEN Z(J2)=QP**POWER(J2) ELSEIF (TEXTC(J2)(2:3).EQ.'qs') THEN Z(J2)=QS**POWER(J2) ENDIF ELSEIF ((TEXTC(J2)(2:2).EQ.'a') * .OR.(TEXTC(J2)(2:2).EQ.'q')) THEN DO 208, I3=1,21 A(1,I3)=0. Q(I3)=0. 208 CONTINUE IF (TEXTC(J2)(1:1).EQ.'+') THEN IF (ICBPOS.NE.0) CALL PARM3(ICBPOS,Z(1),A,RHO,Q) ELSE IF (ICBNEG.NE.0) CALL PARM3(ICBNEG,Z(1),A,RHO,Q) ENDIF IF (TEXTC(J2)(2:4).EQ.'a11') THEN Z(J2)=A(1, 1)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a12') THEN Z(J2)=A(1, 2)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a22') THEN Z(J2)=A(1, 3)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a13') THEN Z(J2)=A(1, 4)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a23') THEN Z(J2)=A(1, 5)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a33') THEN Z(J2)=A(1, 6)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a14') THEN Z(J2)=A(1, 7)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a24') THEN Z(J2)=A(1, 8)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a34') THEN Z(J2)=A(1, 9)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a44') THEN Z(J2)=A(1,10)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a15') THEN Z(J2)=A(1,11)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a25') THEN Z(J2)=A(1,12)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a35') THEN Z(J2)=A(1,13)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a45') THEN Z(J2)=A(1,14)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a55') THEN Z(J2)=A(1,15)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a16') THEN Z(J2)=A(1,16)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a26') THEN Z(J2)=A(1,17)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a36') THEN Z(J2)=A(1,18)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a46') THEN Z(J2)=A(1,19)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a56') THEN Z(J2)=A(1,20)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'a66') THEN Z(J2)=A(1,21)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q11') THEN Z(J2)=Q( 1)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q12') THEN Z(J2)=Q( 2)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q22') THEN Z(J2)=Q( 3)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q13') THEN Z(J2)=Q( 4)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q23') THEN Z(J2)=Q( 5)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q33') THEN Z(J2)=Q( 6)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q14') THEN Z(J2)=Q( 7)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q24') THEN Z(J2)=Q( 8)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q34') THEN Z(J2)=Q( 9)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q44') THEN Z(J2)=Q(10)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q15') THEN Z(J2)=Q(11)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q25') THEN Z(J2)=Q(12)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q35') THEN Z(J2)=Q(13)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q45') THEN Z(J2)=Q(14)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q55') THEN Z(J2)=Q(15)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q16') THEN Z(J2)=Q(16)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q26') THEN Z(J2)=Q(17)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q36') THEN Z(J2)=Q(18)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q46') THEN Z(J2)=Q(19)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q56') THEN Z(J2)=Q(20)**POWER(J2) ELSEIF (TEXTC(J2)(2:4).EQ.'q66') THEN Z(J2)=Q(21)**POWER(J2) ENDIF ELSEIF (TEXTC(J2).EQ.'srf') THEN CALL SRFC2(IVALUE(J2),RAM(J1+1),FF) IF (POWER(J2).EQ.1.) THEN Z(J2)=FF(1) ELSE Z(J2)=FF(1)**POWER(J2) ENDIF ENDIF GOTO 206 ENDIF C End of the loop for other quantities. C Writing the quantities at the point: C Setting output format for the array: FORMAT='(3A,00(F00.0,1X),A)' FORMAT(6:6)=CHAR(ICHAR('0')+MOD(J2,10)) FORMAT(5:5)=CHAR(ICHAR('0')+J2/10) OUTMIN=0. OUTMAX=0. DO 214, I2=1,J2 IF (OUTMIN.GT.Z(I2)) OUTMIN=Z(I2) IF (OUTMAX.LT.Z(I2)) OUTMAX=Z(I2) 214 CONTINUE CALL FORM1(OUTMIN,OUTMAX,FORMAT(8:15)) FORMAT(14:17)= '1X),' C Output format is set. WRITE(LU,FORMAT) '''',TEXTP(1:LENG),''' ',(Z(I2),I2=1,J2),'/' 218 CONTINUE C End of the loop over all points. WRITE(LU,'(A)') '/' CLOSE(LU) C C Storing polygons: IF(PLGN.NE.' ') OPEN(LU1,FILE=PLGN,FORM='FORMATTED') IF(PLGNS.NE.' ')OPEN(LU2,FILE=PLGNS,FORM='FORMATTED') FORMA1='(00(I8,1X),A)' FORMA2='(00(3A,1X),A)' I1=MRAM C Loop over polygons: 220 CONTINUE IF (I1.GT.NPOL) THEN J1=IRAM(I1) I3=MOD(J1,10) FORMA1(3:3)=CHAR(ICHAR('0')+I3) FORMA2(3:3)=CHAR(ICHAR('0')+I3) I3=J1/10 FORMA1(2:2)=CHAR(ICHAR('0')+I3) FORMA2(2:2)=CHAR(ICHAR('0')+I3) J2=IRAM(I1-1) IF ((IRAM(J2-NQPOI+4).NE.0).OR.(IRAM(J2-NQPOI+8).NE.0).OR. * (LFREE)) THEN IF (PLGN.NE.' ') THEN WRITE(LU1,FORMA1) * ((IRAM(I2)-OPOI)/NQPOI,I2=I1-1,I1-J1,-1),'/' ENDIF IF (PLGNS.NE.' ') THEN IF (J1.GT.MLJPOL) THEN C MODSRF-16 CALL ERROR ('MODSRF-16: Disorder in polygons.') C This error should not appear. Contact the author. ENDIF DO 224, I2=I1-1,I1-J1,-1 C Index of the point (from 1 to NPOINT): J2=(IRAM(I2)-OPOI)/NQPOI C Name of the point: I4=I1-I2 DO 222, I3=0,LEN2-1 TEXTS(I4)(1:LEN1)=TEXTP(1:LEN1) TEXTS(I4)(LENG-I3:LENG-I3)= * CHAR(ICHAR('0')+MOD(J2,10**(I3+1))/10**I3) 222 CONTINUE 224 CONTINUE WRITE(LU2,FORMA2) * ('''',TEXTS(I2)(1:LENG),'''',I2=1,J1),'/' ENDIF ENDIF I1=I1-(J1+1) GOTO 220 ENDIF C End of the loop over polygons. IF (PLGN.NE.' ') THEN WRITE(LU1,'(A)') '/' CLOSE(LU1) ENDIF IF (PLGNS.NE.' ') THEN WRITE(LU2,'(A)') '/' CLOSE(LU2) ENDIF C WRITE(*,'(A)') *'+MODSRF: Done. ' STOP END C C======================================================================= C SUBROUTINE FCTMS(X,Y,T) C C----------------------------------------------------------------------- C REAL X,Y(*),T(*) C C Subroutine evaluating the right-hand sides of the interface tracing C equations. I.E. subroutine computing vector T tangent to the C interface. C C Input: C X... Value of the independent variable. C Y... Array containing two coordinates of a C point of the interface, determined by means of numerical C integration. C Output: C Y... Array containing two coordinates of the C interface, corrected by means of the linearization in C the direction of the gradient (perpendicular to the C interface). C T... Array containing derivatives of the coordinates C Y with respect to X (vector tangent to the interface). C----------------------------------------------------------------------- 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: REAL S1,S2,S3,F(10),AUX C C....................................................................... C CALL SRFC2(ISRFO,Y,F) IF (ISRFO.LT.0) THEN S1=F(2) S2=F(3) S3=F(4) ELSE S1=-F(2) S2=-F(3) S3=-F(4) ENDIF IF (IFACE.LE.NFAC1) THEN F(2)=0. S1=0. T(1)=0. AUX=SQRT(S2*S2+S3*S3) T(2)=-S3/AUX T(3)= S2/AUX ELSEIF (IFACE.LE.NFAC12) THEN F(3)=0. S2=0. T(2)=0. AUX=SQRT(S1*S1+S3*S3) T(3)=-S1/AUX T(1)= S3/AUX ELSE F(4)=0. S3=0. T(3)=0. AUX=SQRT(S1*S1+S2*S2) T(1)=-S2/AUX T(2)= S1/AUX ENDIF C C Correction of the isoline AUX=F(1)/AUX/AUX Y(1)=Y(1)-F(2)*AUX Y(2)=Y(2)-F(3)*AUX Y(3)=Y(3)-F(4)*AUX C RETURN END C C======================================================================= C SUBROUTINE OUTMS(X,Y,DERY,IHLF,NDIM,PRMT) C C----------------------------------------------------------------------- C INTEGER IHLF,NDIM REAL X,Y(NDIM),DERY(NDIM),PRMT(*) C C Subroutine to test, whether an interface between two complex blocks C was crossed between the old point (stored from the previous invocation C of OUTMS), and the new point. The new point along the interface C being traced was computed by RKGS. C If the interface is crossed, the indices of simple blocks, C complex blocks, and surfaces ISBO1,ICBO1,ISBO2,ICBO2,ISRFN1,ISRFN2, C ISBN1,ICBN1,ISBN2,ICBN2 are computed and stored in common block MSC. C C Input: C X... Value of the independent variable in the new point. C Y... Array containing the coordinates of the new C point of the interface, determined by means of numerical C integration. C DERY... Array containing derivatives of the coordinates C Y with respect to X (vector tangent to the interface). C IHLF... Number of bisections of the initial increment PRMT(3). C NDIM... Dimension of arrays, should be 3. C PRMT(1).Lower bound of the interval for the independent variable. C PRMT(2).Upper bound of the interval for the independent variable. C PRMT(3).Initial increment of the independent variable. C PRMT(4).Upper error bound. C Output: C If any interface was crossed C and the new point lies within the considered gridface: C No output C If any interface was crossed C and the new point lies outside the considered gridface: C PRMT(5)=2. C If an interface was crossed C and the point of intersection lies within the considered gridface: C PRMT(5)=1. C Y... Array containing the coordinates of the point C of the intersection of the traced and the crossed C interface. C ISBO1,ICBO1,ISBO2,ICBO2,ISRFN1,ISRFN2,ISBN1,ICBN1,ISBN2,ICBN2 ... C The indices of simple blocks, complex blocks, and surfaces C are computed and stored in common block MSC. C----------------------------------------------------------------------- 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 'modsrf.inc' C modsrf.inc. C ........................... EXTERNAL ISIDE,MSLPIF INTEGER ISIDE LOGICAL MSLPIF C Auxiliary storage locations: REAL XTMP1,XTMP(3),DTMP(3),DUMMY(1),ERRSRF,XINT1,DINT(3) REAL X01,X02,X1(3),X2(3) INTEGER IDUMMY,IY1(8),IY2(8),ISUR(2) C....................................................................... IF (IHLF.GT.10) THEN C MODSRF-17 CALL ERROR ('MODSRF-17: Wrong IHLF.') C This error should not appear. Contact the author. ENDIF IF (X.GT.PRMT(1)) THEN X01=0. X02=0. C Calling CDE along side 1: ERRSRF=PRMT(4) XTMP1=X XTMP(1)=Y(1) XTMP(2)=Y(2) XTMP(3)=Y(3) DTMP(1)=DERY(1) DTMP(2)=DERY(2) DTMP(3)=DERY(3) IY1(4)=ISBO1 IY1(5)=ICBO1 IY1(6)=0 CALL CDE(ISRFO,0,IDUMMY,0,IDUMMY,DUMMY,1,3,3,IY1,ERRSRF, * X0,X0,YOLD,DYOLD,X,Y,DERY,XTMP1,XTMP,DTMP,XINT1,X1,DINT) IF (IY1(6).NE.0) THEN C Interface crossed: X01=XTMP1 X1(1)=XTMP(1) X1(2)=XTMP(2) X1(3)=XTMP(3) ENDIF C C Calling CDE along side 2: XTMP1=X XTMP(1)=Y(1) XTMP(2)=Y(2) XTMP(3)=Y(3) DTMP(1)=DERY(1) DTMP(2)=DERY(2) DTMP(3)=DERY(3) IY2(4)=ISBO2 IY2(5)=ICBO2 IY2(6)=0 CALL CDE(ISRFO,0,IDUMMY,0,IDUMMY,DUMMY,1,3,3,IY2,ERRSRF, * X0,X0,YOLD,DYOLD,X,Y,DERY,XTMP1,XTMP,DTMP,XINT1,X2,DINT) IF (IY2(6).NE.0) THEN C Interface crossed: X02=XTMP1 X2(1)=XTMP(1) X2(2)=XTMP(2) X2(3)=XTMP(3) ENDIF C IF ((X01.NE.0.).OR.(X02.NE.0.)) THEN C Interface crossed. C IF ((X01.NE.0.).AND.(X02.NE.0.)) THEN C Choosing the nearer of the two crossed interfaces: IF (X01.LT.X02) THEN X02=0. ELSEIF (X02.LT.X01) THEN X01=0. ENDIF ENDIF C C Recording indices of blocks computed by CDE: IF (X01.NE.0.) THEN ISBO1= IY1(4) ISRFN1=IY1(6) ISBN1= IY1(7) ICBN1= IY1(8) Y(1)=X1(1) Y(2)=X1(2) Y(3)=X1(3) ENDIF IF (X02.NE.0.) THEN ISBO2= IY2(4) ISRFN2=IY2(6) ISBN2= IY2(7) ICBN2= IY2(8) Y(1)=X2(1) Y(2)=X2(2) Y(3)=X2(3) ENDIF C Computing remaining indices of blocks: IF (X01.EQ.0.) THEN ISUR(1)=ISRFO ISUR(2)=ISRFN2 CALL BLOCKS(X2,2,ISUR,ISBO2,IDUMMY,ISBO1,ICBO1) ISRFN1=ISRFN2 IF (ISIDE(ISRFO,ISBN2).LT.2) THEN CALL BLOCKS(X2,2,ISUR,ISBN2,IDUMMY,ISBN1,ICBN1) ELSE ISBN1=ISBN2 ICBN1=ICBN2 ENDIF ENDIF IF (X02.EQ.0.) THEN ISUR(1)=ISRFO ISUR(2)=ISRFN1 CALL BLOCKS(X1,2,ISUR,ISBO1,IDUMMY,ISBO2,ICBO2) ISRFN2=ISRFN1 IF (ISIDE(ISRFO,ISBN1).LT.2) THEN CALL BLOCKS(X1,2,ISUR,ISBN1,IDUMMY,ISBN2,ICBN2) ELSE ISBN2=ISBN1 ICBN2=ICBN1 ENDIF ENDIF c IF (MSLPIF(Y,IFACE)) THEN C Point of intersection lies within the gridface. PRMT(5)=1. c ELSE cC Point of intersection lies outside the gridface. c PRMT(5)=2. c ENDIF ELSE C Interface not crossed. IF (.NOT.MSLPIF(Y,IFACE)) THEN C New point Y is outside the gridface, C RKGS is to be terminated. PRMT(5)=2. ENDIF ENDIF ENDIF C C Storing the old point: X0=X YOLD(1)=Y(1) YOLD(2)=Y(2) YOLD(3)=Y(3) DYOLD(1)=DERY(1) DYOLD(2)=DERY(2) DYOLD(3)=DERY(3) RETURN END C C C======================================================================= C SUBROUTINE MSGLEG(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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,ILEG1 C....................................................................... C ILEG1=ILEG-1 IF (ILEG.LE.NLEG1) THEN I31=ILEG1 / N11N2 I21=(ILEG1 - I31*N11N2) / N11 I1=ILEG - I31*N11N2 - I21*N11 IPOIN1=I31*N1N2+I21*N1+I1 IPOIN2=IPOIN1+1 ELSEIF (ILEG.LE.NLEG12) THEN I31=(ILEG1-NLEG1) / N1N21 I21=((ILEG1-NLEG1) - I31*N1N21) / N1 I1=(ILEG-NLEG1) - I31*N1*N21 - I21*N1 IPOIN1=I31*N1N2+I21*N1+I1 IPOIN2=IPOIN1+N1 ELSEIF (ILEG.LE.NLEG) THEN I31=(ILEG1-NLEG12) / N1N2 I21=((ILEG1-NLEG12) - I31*N1N2) / N1 I1=(ILEG-NLEG12) - I31*N1N2 - I21*N1 IPOIN1=I31*N1N2+I21*N1+I1 IPOIN2=IPOIN1+N1*N2 ELSE C MODSRF-18 CALL ERROR ('MODSRF-18: Wrong ILEG.') C This error should not appear. Contact the author. ENDIF RETURN END C C C======================================================================= C SUBROUTINE MSGFAC(IFAC,ILEG1,ILEG2,ILEG3,ILEG4) C C----------------------------------------------------------------------- C INTEGER IFAC,ILEG1,ILEG2,ILEG3,ILEG4 C IFAC ... Index of gridface. C ILEG1,ILEG2,ILEG3,ILEG4 ... Indices of gridlegs forming C the gridface. 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,IFAC1 C....................................................................... C IFAC1=IFAC-1 IF (IFAC.LE.NFAC1) THEN I31= IFAC1 / N1N21 I21=(IFAC1 - I31*N1N21) / N1 I1 = IFAC - I31*N1N21 - I21*N1 ILEG1=NLEG1 + I31*N1N21+I21*N1+I1 ILEG4=NLEG12 + I31*N1N2+I21*N1+I1 ILEG2=ILEG4+N1 ILEG3=ILEG1+N1N21 ELSEIF (IFAC.LE.NFAC12) THEN I31= (IFAC1-NFAC1) / N11N2 I21=((IFAC1-NFAC1) - I31*N11N2) / N11 I1 = (IFAC-NFAC1) - I31*N11N2 - I21*N11 ILEG1=NLEG12 + I31*N1N2+I21*N1+I1 ILEG4= I31*N11N2+I21*N11+I1 ILEG2=ILEG4+N11N2 ILEG3=ILEG1+1 ELSEIF (IFAC.LE.NFAC) THEN I31= (IFAC1-NFAC12) / N11N21 I21=((IFAC1-NFAC12) - I31*N11N21) / N11 I1 = (IFAC-NFAC12) - I31*N11N21 - I21*N11 ILEG1= I31*N11N2+I21*N11+I1 ILEG4=NLEG1 + I31*N1N21+I21*N1+I1 ILEG2=ILEG4+1 ILEG3=ILEG1+N11 ELSE C MODSRF-19 CALL ERROR ('MODSRF-19: Wrong IFAC.') C This error should not appear. Contact the author. ENDIF RETURN END C C C======================================================================= C SUBROUTINE MSGCUB(ICUB,IFAC1,IFAC2,IFAC3,IFAC4,IFAC5,IFAC6) C C----------------------------------------------------------------------- C INTEGER ICUB,IFAC1,IFAC2,IFAC3,IFAC4,IFAC5,IFAC6 C ICUB ... Index of gridcube. C IFAC1,...,IFAC6 ... Indices of gridfaces forming the gridcube. 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,ICUB1 C....................................................................... C IF ((ICUB.LT.1).OR.(ICUB.GT.NCUB)) THEN C MODSRF-20 CALL ERROR ('MODSRF-20: Wrong ICUB.') C This error should not appear. Contact the author. ENDIF ICUB1=ICUB-1 I31= ICUB1 / N11N21 I21=(ICUB1 - I31*N11N21) / N11 I1= ICUB - I31*N11N21 - I21*N11 IFAC1= I31*N1N21 +I21*N1 +I1 IFAC2=NFAC1 +I31*N11N2 +I21*N11+I1 IFAC3=NFAC12+I31*N11N21+I21*N11+I1 IFAC4=IFAC1+1 IFAC5=IFAC2+N11 IFAC6=IFAC3+N11N21 RETURN END C C C======================================================================= C LOGICAL FUNCTION MSLPIF(XX,IFAC) C C----------------------------------------------------------------------- C Subroutine for decision, whether the point with coordinates XX C lies inside gridface IFAC. C INTEGER IFAC REAL XX(3) C Input: C XX ... Coordinates of the point. C IFAC ... Index of the gridface. C Output: C MSLPIF ... .TRUE. when the point lies inside the gridface. 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,IFAC1,IP1,IP2 INTEGER ILEG1,ILEG2 REAL XA1,XA2,XA3,XB1,XB2,XB3,XC1,XC2,XC3 C....................................................................... C IFAC1=IFAC-1 IF (IFAC.LE.NFAC1) THEN I31= IFAC1 / N1N21 I21=(IFAC1 - I31*N1N21) / N1 I1 = IFAC - I31*N1N21 - I21*N1 ILEG1=NLEG1 + I31*N1N21+I21*N1+I1 ILEG2=NLEG12 + I31*N1N2+I21*N1+I1 + N1 ELSEIF (IFAC.LE.NFAC12) THEN I31= (IFAC1-NFAC1) / N11N2 I21=((IFAC1-NFAC1) - I31*N11N2) / N11 I1 = (IFAC-NFAC1) - I31*N11N2 - I21*N11 ILEG1=NLEG12 + I31*N1N2+I21*N1+I1 ILEG2= I31*N11N2+I21*N11+I1 + N11N2 ELSEIF (IFAC.LE.NFAC) THEN I31= (IFAC1-NFAC12) / N11N21 I21=((IFAC1-NFAC12) - I31*N11N21) / N11 I1 = (IFAC-NFAC12) - I31*N11N21 - I21*N11 ILEG1= I31*N11N2+I21*N11+I1 ILEG2=NLEG1 + I31*N1N21+I21*N1+I1 + 1 ELSE C MODSRF-21 CALL ERROR ('MODSRF-21: Wrong IFAC.') C This error should not appear. Contact the author. ENDIF C MSLPIF=.TRUE. C CALL MSGLEG(ILEG1,IP1,IP2) CALL MSCP(IP1,XA1,XA2,XA3) CALL MSCP(IP2,XB1,XB2,XB3) CALL MSGLEG(ILEG2,IP1,IP2) CALL MSCP(IP2,XC1,XC2,XC3) IF ((XX(1).LT.AMIN1(XA1,XB1,XC1)).OR. * (XX(1).GT.AMAX1(XA1,XB1,XC1))) MSLPIF=.FALSE. IF ((XX(2).LT.AMIN1(XA2,XB2,XC2)).OR. * (XX(2).GT.AMAX1(XA2,XB2,XC2))) MSLPIF=.FALSE. IF ((XX(3).LT.AMIN1(XA3,XB3,XC3)).OR. * (XX(3).GT.AMAX1(XA3,XB3,XC3))) MSLPIF=.FALSE. RETURN END C C C======================================================================= C LOGICAL FUNCTION MSLPIL(XX,ILEG) C C----------------------------------------------------------------------- C Subroutine for decision, whether the point with coordinates XX C lies inside gridleg ILEG. C INTEGER ILEG REAL XX(3) C Input: C XX ... Coordinates of the point. C ILEG ... Index of the gridleg. C Output: C MSLPIL ... .TRUE. when the point lies inside 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER IP1,IP2 REAL XA1,XA2,XA3,XB1,XB2,XB3 C....................................................................... C CALL MSGLEG(ILEG,IP1,IP2) CALL MSCP(IP1,XA1,XA2,XA3) CALL MSCP(IP2,XB1,XB2,XB3) MSLPIL=.TRUE. IF ((XX(1).LT.AMIN1(XA1,XB1)).OR. * (XX(1).GT.AMAX1(XA1,XB1))) MSLPIL=.FALSE. IF ((XX(2).LT.AMIN1(XA2,XB2)).OR. * (XX(2).GT.AMAX1(XA2,XB2))) MSLPIL=.FALSE. IF ((XX(3).LT.AMIN1(XA3,XB3)).OR. * (XX(3).GT.AMAX1(XA3,XB3))) MSLPIL=.FALSE. RETURN END C C C======================================================================= C SUBROUTINE MSGCGP(ICUB,IP1,IP2,IP3,IP4,IP5,IP6,IP7,IP8) C C----------------------------------------------------------------------- C Subroutine for debugging purposes, gives indices of points C of cube ICUB. C C INTEGER ICUB,IP1,IP2,IP3,IP4,IP5,IP6,IP7,IP8 C ICUB ... Index of gridcube. C IP1,...,IP8 ... Indices of gridpoints forming the gridcube. 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,ICUB1 C....................................................................... C IF ((ICUB.LT.1).OR.(ICUB.GT.NCUB)) THEN C MODSRF-22 CALL ERROR ('MODSRF-22: Wrong ICUB.') C This error should not appear. Contact the author. ENDIF ICUB1=ICUB-1 I31= ICUB1 / N11N21 I21=(ICUB1 - I31*N11N21) / N11 I1= ICUB - I31*N11N21 - I21*N11 IP1=I31*N1N2+I21*N1+I1 IP2=IP1+N1 IP3=IP2+N1N2 IP4=IP1+N1N2 IP5=IP1+1 IP6=IP5+N1 IP7=IP6+N1N2 IP8=IP5+N1N2 RETURN END C C C======================================================================= C SUBROUTINE MSXFAC(IFAC) C C----------------------------------------------------------------------- C Subroutine for debugging purposes, gives coordinates of points C of face IFAC. C INTEGER IFAC,ILEG1,ILEG2,ILEG3,ILEG4 C IFAC ... Index of gridface. C ILEG1,ILEG2,ILEG3,ILEG4 ... Indices of gridlegs forming C the gridface. 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 'modsrf.inc' C modsrf.inc. C ........................... C Auxiliary storage locations: INTEGER I31,I21,I1,IFAC1,IP1,IP2 REAL X1,X2,X3 C....................................................................... C IFAC1=IFAC-1 IF (IFAC.LE.NFAC1) THEN I31= IFAC1 / N1N21 I21=(IFAC1 - I31*N1N21) / N1 I1 = IFAC - I31*N1N21 - I21*N1 ILEG1=NLEG1 + I31*N1N21+I21*N1+I1 ILEG4=NLEG12 + I31*N1N2+I21*N1+I1 ILEG2=ILEG4+N1 ILEG3=ILEG1+N1N21 ELSEIF (IFAC.LE.NFAC12) THEN I31= (IFAC1-NFAC1) / N11N2 I21=((IFAC1-NFAC1) - I31*N11N2) / N11 I1 = (IFAC-NFAC1) - I31*N11N2 - I21*N11 ILEG1=NLEG12 + I31*N1N2+I21*N1+I1 ILEG4= I31*N11N2+I21*N11+I1 ILEG2=ILEG4+N11N2 ILEG3=ILEG1+1 ELSEIF (IFAC.LE.NFAC) THEN I31= (IFAC1-NFAC12) / N11N21 I21=((IFAC1-NFAC12) - I31*N11N21) / N11 I1 = (IFAC-NFAC12) - I31*N11N21 - I21*N11 ILEG1= I31*N11N2+I21*N11+I1 ILEG4=NLEG1 + I31*N1N21+I21*N1+I1 ILEG2=ILEG4+1 ILEG3=ILEG1+N11 ELSE C MODSRF-23 CALL ERROR ('MODSRF-23: Wrong IFAC.') C This error should not appear. Contact the author. ENDIF CALL MSGLEG(ILEG1,IP1,IP2) CALL MSCP(IP1,X1,X2,X3) CALL MSCP(IP2,X1,X2,X3) C CALL MSGLEG(ILEG2,IP1,IP2) CALL MSCP(IP1,X1,X2,X3) CALL MSCP(IP2,X1,X2,X3) C CALL MSGLEG(ILEG3,IP1,IP2) CALL MSCP(IP1,X1,X2,X3) CALL MSCP(IP2,X1,X2,X3) C CALL MSGLEG(ILEG4,IP1,IP2) CALL MSCP(IP1,X1,X2,X3) CALL MSCP(IP2,X1,X2,X3) C RETURN END C C C======================================================================= C SUBROUTINE MSCP(IPOIN,X1,X2,X3) C C----------------------------------------------------------------------- C INTEGER IPOIN REAL X1,X2,X3 C IPOIN ... Index of a point. C X1,X2,X3 ... 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 'modsrf.inc' C modsrf.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 X1=O1+FLOAT(I11)*D1 X2=O2+FLOAT(I21)*D2 X3=O3+FLOAT(I31)*D3 RETURN END C C======================================================================= C SUBROUTINE MSJCN(JCN,NJCN,MJCN) C C----------------------------------------------------------------------- C Subroutine for marking sure and wrong connections in array JCN. C INTEGER MJCN,JCN(4,MJCN),NJCN C JCN(1 to 4,i) ... Connection i of the face: address of the first C point, address of the second point, index of the interface, C status of the connection. C Auxiliary storage locations: INTEGER I4,I3,I2 C....................................................................... C 10 CONTINUE I4=0 DO 60, I2=1,NJCN C Loop over unsure connections: IF (JCN(4,I2).EQ.0) THEN DO 20, I3=1,NJCN C Loop over other connections with the same starting point: IF ((I3.NE.I2).AND.(JCN(1,I3).EQ.JCN(1,I2))) THEN IF (JCN(4,I3).EQ.1) THEN C Another connection is sure, connection I2 is wrong. JCN(4,I2)=-1 GOTO 50 ELSEIF (JCN(4,I3).EQ.0) THEN C Another unsure connection, connection I2 is unsure. GOTO 30 ENDIF ENDIF 20 CONTINUE C No other connection, connection I2 is sure. JCN(4,I2)=1 GOTO 50 30 CONTINUE DO 40, I3=1,NJCN C Loop over other connections with the same end point: IF ((I3.NE.I2).AND.(JCN(2,I3).EQ.JCN(2,I2))) THEN IF (JCN(4,I3).EQ.1) THEN C Another connection is sure, connection I2 is wrong. JCN(4,I2)=-1 GOTO 50 ELSEIF (JCN(4,I3).EQ.0) THEN C Another unsure connection, connection I2 is unsure. GOTO 50 ENDIF ENDIF 40 CONTINUE C No other connection, connection I2 is sure. JCN(4,I2)=1 50 CONTINUE C Noting the change in the status of the connection: IF (JCN(4,I2).NE.0) I4=1 ENDIF 60 CONTINUE C Change in the status of a connection implies C the repetition of the loop: IF (I4.EQ.1) GOTO 10 RETURN END C C======================================================================= C SUBROUTINE MSEROR(IERR) C C----------------------------------------------------------------------- C INTEGER IERR C IERR ... Index of the error. C....................................................................... IF (IERR.EQ.1) THEN C MODSRF-24 CALL ERROR('MODSRF-24: Small array (I)RAM.') C Try to enlarge the dimension MRAM in the file C ram.inc. The memory requirements C of this program are roughly 8*N1*N2*N3+12*NPTS, where N1*N2*N3 C is the dimension of the input grid, and NPTS is the number of C intersections of gridlegs with structural interfaces. ELSEIF (IERR.EQ.2) THEN C MODSRF-25 CALL ERROR('MODSRF-25: Small array JPT.') C Try to enlarge the dimension MJPT at the beginning of this file. C If this does not help, contact the author. ELSEIF (IERR.EQ.3) THEN C MODSRF-26 CALL ERROR('MODSRF-26: Small array IPTE.') C Try to enlarge the dimension MIPTE at the beginning of this file. C If this does not help, contact the author. ELSEIF (IERR.EQ.4) THEN C MODSRF-27 CALL ERROR('MODSRF-27: Small array JCN.') C Try to enlarge the dimension MJCN at the beginning of this file. C If this does not help, contact the author. ELSEIF (IERR.EQ.6) THEN C MODSRF-29 CALL ERROR('MODSRF-29: Small array JPOL.') C Try to enlarge the dimension MJPOL at the beginning of this file. C If this does not help, contact the author. ELSEIF (IERR.EQ.7) THEN C MODSRF-30 CALL ERROR('MODSRF-30: Small array JPOL.') C Try to enlarge the dimension MLJPOL at the beginning of this file. C If this does not help, contact the author. ELSEIF (IERR.EQ.8) THEN C MODSRF-05 CALL ERROR('MODSRF-05: Interface not found.') C This might happen when the whole gridleg coincides with an C interface. If possible, slightly change the origin of C the grid. If this does not help, contact the author. ELSE C MODSRF-31 CALL ERROR('MODSRF-31: Wrong IERR.') C This subroutine was invocated with wrong value of IERR. C This error should not appear, please contact the author. ENDIF 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for INCLUDE 'means.for' C means.for INCLUDE 'rkgs.for' C rkgs.for C C======================================================================= Cmodsrf.inc 0100666 0000765 0000765 00000003075 06707532000 012422 0 ustar bulant bulant CC INCLUDE 'modsrf.inc' C Declaration of the common blocks used through MODSRF program: C C Date: 1999, April 7 C C ------------------------------------------------------------------ INCLUDE 'ram.inc' C ram.inc INTEGER IRAM(MRAM) EQUIVALENCE (IRAM,RAM) C C Parameters defining the grid: INTEGER N1,N2,N3 REAL O1,O2,O3,D1,D2,D3 C Auxiliary parameters of the grid: INTEGER N11,N21,N1N2,N11N2,N1N21,N11N21 C Parameters for managing arrays RAM and IRAM: INTEGER NGPS,NLEG,NLEG1,NLEG2,NLEG3,NLEG12,NFAC,NFAC1,NFAC2,NFAC3, * NFAC12,NCUB,OLEG,OFAC,OPOI,NPOI,NPOIL,NPOIE,NPOILP,NPOIEP, * NQPOI,OCON,NCON,NPOL PARAMETER(NQPOI=8) C Auxiliary quantities used when calling RKGS: INTEGER ISRFO,IFACE,ISBO1,ICBO1,ISBO2,ICBO2, * ISRFN1,ISRFN2,ISBN1,ICBN1,ISBN2,ICBN2 REAL X0,YOLD(3),DYOLD(3) C COMMON/MSC/N1,N2,N3,O1,O2,O3,D1,D2,D3,N11,N21,N1N2,N11N2,N1N21, * N11N21,NGPS,NLEG,NLEG1,NLEG2,NLEG3,NLEG12,NFAC,NFAC1,NFAC2,NFAC3, * NFAC12,NCUB,OLEG,OFAC,OPOI,NPOI,NPOIL,NPOIE,NPOILP,NPOIEP,OCON, * NCON,NPOL,ISRFO,IFACE,ISBO1,ICBO1,ISBO2,ICBO2,X0,YOLD,DYOLD, * ISRFN1,ISRFN2,ISBN1,ICBN1,ISBN2,ICBN2 SAVE /MSC/ C ------------------------------------------------------------------ C C Coded by Petr Bulant C======================================================================= Cparm.for 0100666 0000765 0000765 00000114010 06756443476 012122 0 ustar bulant bulant CC Subroutine file 'parm.for' for specification and interpolation of the C material parameters of the model in rectangular grids. C C Date: 1999, August 18 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C PARM1...Subroutine reading the input data for the material C parameters of the model. C PARM1 C PARM2...Subroutine evaluating the isotropic material parameters C including their first and second derivatives. C The functions may be embedded: the independent variable C of the function may be another material parameter of the C same complex block foregoing in the input data. C PARM2 C ADD10...Auxiliary subroutine to PARM2 summing 3 arrays of C dimension 10. C ADD10 C LIN10...Auxiliary subroutine to PARM2 evaluating the linear C combination of 3 arrays of dimension 10. C LIN10 C PARM3...Subroutine evaluating the anisotropic material parameters C including their first and second derivatives. C PARM3 C PARM4...Entry of subroutine PARM3 answering whether the model is C isotropic or anisotropic. C PARM4 C Subroutines PARM1, PARM2, and PARM3, supporting isotropic complete ray C tracing algorithm, anisotropic ray tracing and other seismic modelling C algorithms, only mediate the work of subroutines VAL1, VAL2 and FPOWER C which must be appended. In addition, subroutines CURVN1 (or its C alternative CURVB1), CURV2D (or its alternative CURVBD), SURFB1, C SURFBD, VAL3B1, VAL3BD, VGEN, TERMS, SNHCSH, TRIDEC, TRISOL, DSPLNZ, C INTRVL from the subroutine package 'FITPACK' by Alan Kaylor Cline, C Department of Computer Sciences, University of Texas at Austin, are C used. In the complete ray tracing, this software file 'parm.for' may C be replaced by any user-defined package containing subroutines PARM1 C and PARM2 with the same number, type and meaning of their parameters C as in this file. C C Note: C The lines denoted by '*V' in the first two columns of file C 'parm.for' are designed to calculate the model variations with C respect to the model parameters. C File 'parmv.for', intended for the model inversion, is created C from 'parm.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C C If model variations are taken into account: C Model variations are assumed to be stored while evaluating the C functions during the invocation of subroutine VAL of file C 'val.for' and subsequent routines of file 'fit.for'. C The variations of P-wave velocity are assumed to be stored in C register 1 of the system VAR*, the variations of S-wave velocity C are assumed to be stored in register 2 of the system VAR*. C Variations of the density and loss (or quality) factors are not C considered, although they may be stored in other registers. C Subroutines VAR4 and VAR5 are called within the subroutine PARM2 C in order to deal with the variations of P and S wave velocities. C C....................................................................... C C C Input data (read in by subroutine PARM1): C These input data define the complex blocks. They are read in by C subroutine PARM1. The number NCB of the complex blocks to be C defined is an input argument of subroutine PARM1. The data are C read in by the list directed input (free format). C (1) NCB-times (i.e. once for each complex block) input data (1A)+(1B): C (1A) TEXTG,ICB C Identification of the complex block. C TEXTG...Any string. Its first 3 characters must differ from C 'VP ', 'VS ', 'DEN', 'QP ', 'QS ', C 'A11', 'A12', 'A22', 'A13', 'A23', 'A33', 'A14', 'A24', C 'A34', 'A44', 'A15', 'A25', 'A35', 'A45', 'A55', 'A16', C 'A26', 'A36', 'A46', 'A56', 'A66', C 'B11', 'B12', 'B22', 'B13', 'B23', 'B33', 'B14', 'B24', C 'B34', 'B44', 'B15', 'B25', 'B35', 'B45', 'B55', 'B16', C 'B26', 'B36', 'B46', 'B56', 'B66', C 'Q11', 'Q12', 'Q22', 'Q13', 'Q23', 'Q33', 'Q14', 'Q24', C 'Q34', 'Q44', 'Q15', 'Q25', 'Q35', 'Q45', 'Q55', 'Q16', C 'Q26', 'Q36', 'Q46', 'Q56', 'Q66', 'END'. C ICB... Index of the complex block. C (1B) Several times 'Input data for one material parameter', see below. C Isotropic complex block: C At least one of velocities 'VP ' and 'VS ' must be specified. C Unspecified isotropic elastic parameters ('VP ', 'VS ', 'QP ', C 'QS ') take their default values. Anisotropic elastic C parameters correspond to the isotropic medium. C Anisotropic complex block with given isotropic reference medium: C Isotropic complex block with one to all anisotropic elastic C parameters specified. Unspecified anisotropic elastic C parameters default to the isotropic medium. C Anisotropic complex block: C At least 9 reduced anisotropic elastic parameters 'A11', 'A12', C 'A22', 'A13', 'A23', 'A33', 'A44', 'A55', and 'A66' must be C specified in the anisotropic complex block. Unspecified C anisotropic elastic parameters default to zeros. C (2) TEXTE,AUX C End of data. C TEXTE...String, the first 3 characters of which must be upper-case C 'END'. C AUX... Any number or a slash. C For an example refer to the sample input data for the model. C C Input data for one material parameter: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new read statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise (except TEXTF), the input parameter is of the C type REAL. C (1) TEXTF,POWER C Physical meaning of the function. C TEXTF...String identifying which material parameter the function C describes. Only the first 3 characters are significant. C The first 3 characters of the string must be: C 'VP ' for P wave velocity, C 'VS ' for S wave velocity, C 'DEN' for density, C 'QP ' for P wave loss factor, C 'QS ' for S wave loss factor. C 'A11', 'A12', 'A22', 'A13', 'A23', 'A33', 'A14', 'A24', C 'A34', 'A44', 'A15', 'A25', 'A35', 'A45', 'A55', 'A16', C 'A26', 'A36', 'A46', 'A56', or 'A66' for reduced (i.e. C divided by the density) anisotropic elastic parameters C (components of the real part of the symmetric 6*6 C stiffness matrix divided by the density). C 'Q11', 'Q12', 'Q22', 'Q13', 'Q23', 'Q33', 'Q14', 'Q24', C 'Q34', 'Q44', 'Q15', 'Q25', 'Q35', 'Q45', 'Q55', 'Q16', C 'Q26', 'Q36', 'Q46', 'Q56', or 'Q66' for reduced (i.e. C divided by the density) imaginary anisotropic elastic C parameters (components of the imaginary part of the C symmetric 6*6 stiffness matrix divided by the density). C All strings must be entered in uppercase. C POWER...The specified function is equal to the POWER-th power of C the material parameter. C Examples: C For P wave velocity TEXTF='VP ' and POWER=1.0, C for P wave slowness TEXTF='VP ' and POWER=-1.0, C for S wave quadratic slowness TEXTF='VS ' and C POWER=-2.0, C for P wave loss factor TEXTF='QP ' and POWER=1.0, C for S wave quality factor TEXTF='QS ' and POWER=-1.0. C Default values of isotropic elastic parameters not specified in C the input data (subroutine PARM2): C Isotropic complex block or anisotropic complex block with C given isotropic reference medium (at least one of VP and C VS given): C P wave velocity: VP=1.73205*VS, C S wave velocity: VS=0.57735*VP, C Anisotropic complex block (neither VP nor VS given): C Default isotropic parameters are expressed in terms of C anisotropic parameters to allow for application of the C isotropic code to anisotropic models. C Average isotropic medium minimizing the squared norm of C the difference between the Christoffel matrices, C averaged over propagation directions: C AP=A11+A22+A33, C AL=A12+A13+A23, C AS=A44+A55+A66, C VP=SQRT( (3.*AP+2.*AL+4.*AS)/15 ), C VS=SQRT( ( AP - AL+3.*AS)/15 ), C This reference isotropic medium is designed especially C to serve as a basis for anisotropic perturbations. From C this point of view, the variations of the these default C isotropic material parameters with respect to the model C parameters, evaluated by means of subroutines VAR*, are C unnecessary. No variations of the above defaults are C thus set in PARM2. C In any case: C Density: RHO=1, C P wave loss factor (if S wave loss factor is specified): C QP=1.333333*QS*(US(1)/UP(1))**2, C S wave loss factor (if P wave loss factor is specified): C QS=0.750000*QP*(UP(1)/US(1))**2, C P and S wave loss factors (if none of them is given): C QP=0.0, QS=0.0. C Default values of anisotropic elastic parameters not specified in C the input data (subroutine PARM3): C Isotropic complex block or anisotropic complex block with C given isotropic reference medium (at least one of VP and C VS given): C Default anisotropic parameters are expressed in terms of C isotropic parameters for the sake of continuity with C isotropic models: C A11=A22=A33= VP*VP, C A12=A13=A23= VP*VP-2*VS*VS, C A44=A55=A66= VS*VS, C A14=A24=A34=A15=A25=A35=A45=A16=A26=A36=A46=A56= 0. C Anisotropic complex block (neither VP nor VS given): C Aij=0. C In any case: C RHO=1, C Qij=0 in this version. C (2) IVAR1,IVAR2,IVAR3,SIGMA,POWERW,/ C The form of the function. C IVAR1,IVAR2,IVAR3... Denote the form of the function. The function C must be of the form C F(X1,X2,X3) = W(A1,A2,A3)-B1-B2-B3 . C X1, X2, X3 are the general coordinates. Each of A1, A2, C A3, B1, B2, B3 must be either: (a) one of general C coordinates X1, X2, X3, (b) another previously defined C function F(X1,X2,X3) of the same complex block, or (c) C must be left out. At most 3 of parameters A1-B3 may be of C kind (a) or (b). Note that IVAR1 controls the type of A1 C and B1, IVAR2 controls the type of A2 and B2, IVAR3 C controls the type of A3 and B3. C For IVAR1.EQ.0: A1, B1 are empty (left out). C For IVAR1.EQ.1: A1=X1, B1 is empty. C For IVAR1.EQ.2: A1=X2, B1 is empty. C For IVAR1.EQ.3: A1=X3, B1 is empty. C For IVAR1.GE.4: A1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same complex block defined in C the input data as the (IVAR1-3)-th function of the C complex block. B1 is empty. C Example: C If density=1.7+0.2*VP then the interpolated function C is W(A1,A2,A3)=1.7+0.2*A1 with the independent C variable A1=VP(X1,X2,X3). This is specified by C IVAR1=4, IVAR2=0, IVAR3=0 if VP is the first read in C parameter, by IVAR1=5, IVAR2=0, IVAR3=0 if VP is the C second read in parameter, etc. C The possible alternatives are W(A1,A2,A3)=1.7+0.2*A2 C with A2=VP(X1,X2,X3) specified by IVAR1=0, C IVAR2=(4 or 5 or the like), IVAR3=0, and C W(A1,A2,A3)=1.7+0.2*A3 with A3=VP(X1,X2,X3) specified C by IVAR1=0, IVAR3=2, IVAR3=(4 or 5 or the like). C For IVAR1.EQ.-1: B1=X1, A1 is empty. C For IVAR1.EQ.-2: B1=X2, A1 is empty. C For IVAR1.EQ.-3: B1=X3, A1 is empty. C For IVAR1.GE.-4: B1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same complex block defined in C the input data as the (-IVAR1-3)-th function of the C complex block. A1 is empty. C The meaning of the parameters IVAR2, IVAR3 is similar. C Examples: C IVAR1: IVAR2: IVAR3: the form of the function: C 1 2 3 F(X1,X2,X3)=W(X1,X2,X3) C 3 1 2 F(X1,X2,X3)=W(X3,X1,X2) C 1 2 0 F(X1,X2,X3)=W(X1,X2) C 5 0 0 F(X1,X2,X3)=W(F2(X1,X2,X3)), where C F2(X1,X2,X3) is the second material parameter of the C complex block defined in the input data. Function W is C interpolated by means of splines under tension. C SIGMA...Is the tension factor (its sign is ignored). This value C indicates the curviness desired. If ABS(SIGMA) is nearly C zero (e.g. 0.001), the resulting surface is approximately C the tensor product of cubic splines. If ABS(SIGMA) is C large (e.g. 50.), the resulting surface is approximately C tri-linear. If SIGMA equals zero, tensor products of C cubic splines result. A recommended value for SIGMA is C approximately 1. In absolute value. C POWERW..Given grid values (7) correspond to the POWERW-th power of C interpolated function W. The given grid values (7) are C thus raised to the (1/POWERW)-th power immediately after C reading and then interpolated. C /... Obligatory slash at the end of line for future extensions. C Default: IVAR1=0, IVAR2=0, IVAR3=0, SIGMA=0, POWERW=1. C (3) NX(1),...,NX(NVAR) C The numbers of grid coordinates for the interpolation. C This input is performed if at least one of IVAR1, IVAR2, IVAR3 is C positive. C Each of NX(1),...,NX(NVAR) corresponds to one positive value of C IVAR1, IVAR2, IVAR3 and specifies the number of grid coordinates C corresponding to that independent variable of function W, see (2). C The sign of NX(1),...,NX(NVAR) is ignored. NVAR (.LE.3) is the C number of positive values of the above quantities IVAR1, IVAR2, C IVAR3, i.e. the number of independent variables of function W, C see (1). C (4) X1(1),...,X1(NX(1)) C The grid coordinates corresponding to the first independent C variable of function W, see (2). C This input is performed if NX(1) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (5) X2(1),...,X2(NX(2)) C The grid coordinates corresponding to the second independent C variable of function W, see (2). C This input is performed if NX(2) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (6) X3(1),...,X3(NX(3)) C The grid coordinates corresponding to the third independent C variable of function W, see (2). C This input is performed if NX(3) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (7) (((W(I,J,K),I=1,MAX(NX(1),1)),J=1,MAX(NX(2),1)),K=1,MAX(NX(3),1)) C the values of function W at grid points. Function value W(i,j,k) C corresponds to point (X1(I),X2(J),X3(K)). C C======================================================================= C C C SUBROUTINE PARM1(LUN,NCB) INTEGER LUN,NCB C C This subroutine reads the input data for the distributions of the C material parameters: C In the isotropic complex blocks: C P and S wave velocities, density, P and S wave loss factors C in the anisotropic complex blocks: C 21 real parts of the reduced (divided by the density) elastic C parameters, 21 corresponding imaginary parts, density. C Reference isotropic P and S velocities and loss factors may also be C specified together with anisotropic material parameters. C When reading the data, subroutine PARM1 also determines the parameters C necessary to compute an interpolatory function on a three dimensional C rectangular grid, and stores them in the memory. The function C determined can be represented as a tensor product of splines under C tension. The functions may be embedded. For actual interpolation of C material parameters it is necessary to call subroutine PARM2 for C isotropic model (or mean isotropic model corresponding to the C anisotropic model), or subroutine PARM3 for anisotropic material C parameters of the isotropic or anisotropic model. Subroutines PARM2 C and PARM3 also return the first and second partial derivatives of C propagation velocities or reduced elastic parameters. Subroutine C PARM1 may be called several times. The complex blocks are indexed C successively, following the complex blocks defined during the previous C invocations. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C NCB... Number of the material complex blocks for which the input C data are specified during the current invocation of PARM1. C None of the input parameters are altered. C C No output. C C Subroutines and external functions required: EXTERNAL VAL1 C VAL1, SORTV, READV... File 'val.for'. C CURVN1 or CURVB1 (alternatives), SURFB1, VAL3B1, SNHCSH, VGEN, C TERMS, TRIDEC, TRISOL... Subroutine package 'FITPACK' C (file 'fit.for'). C C Date: 1995, December 17 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: CHARACTER*3 TFUNCT(47) DATA TFUNCT/'VP ','VS ','DEN','QP ','QS ', *'A11','A12','A22','A13','A23','A33','A14','A24','A34','A44', *'A15','A25','A35','A45','A55','A16','A26','A36','A46','A56','A66', *'Q11','Q12','Q22','Q13','Q23','Q33','Q14','Q24','Q34','Q44', *'Q15','Q25','Q35','Q45','Q55','Q16','Q26','Q36','Q46','Q56','Q66'/ C CALL VAL1(LUN,2,NCB,47,TFUNCT) RETURN END C C======================================================================= C C C SUBROUTINE PARM2(ICB,COOR,UP,US,RHO,QP,QS) INTEGER ICB REAL COOR(3),UP(10),US(10),RHO,QP,QS C C This subroutine evaluates P and S wave velocities, density, and P and C S wave loss factors at a given point. The three first and six second C partial derivatives of the velocities are also evaluated. The C specified functions are represented as a tensor product of splines C under tension. The parameters may be dependent either on the general C coordinates or on the distribution of another parameter, e.g. C VS=0.577*VP or RHO=1.7+0.2*VP, where VP, VS and RHO are P and S C velocities and density. The coefficients of these functions are C prepared in subroutine PARM1, in which the input data concerning the C distribution of individual parameters within each complex block are C read in. The default values of parameters not specified in the input C data are: C P wave velocity: VP=1.73205*VS, C S wave velocity: VS=0.57735*VP, C Density: RHO=1.0, C P wave loss factor (if the S wave loss factor is specified): C QP=1.333333*QS*(US(1)/UP(1))**2, C S wave loss factor (if the P wave loss factor is specified): C QS=0.750000*QP*(UP(1)/US(1))**2, C P and S wave loss factors (if none of them is specified): C QP=0.0, QS=0.0. C Attention: The above default values are reasonable only if arguments C UP and US of this subroutine are velocities, and QP and QS loss C factors. In other words, these default settings are useful only C if NEXPV=1 and NEXPQ=1 in the input data set model, line (2). C Note that at least one of the velocities must be specified in the C input data. P wave velocity must be positive, other material C parameters must be non-negative. C C Input: C ICB... Index of a complex block. C COOR... Array containing coordinates X1, X2, X3 of the given C point. C None of the input parameters are altered. C C Output: C UP,US...Powers of the P and S wave velocities (the exponent of the C power is NEXPV, see the input data for the model) and C their first and second partial derivatives in order U, U1, C U2, U3, U11, U12, U22, U13, U23, U33, at the given point. C RHO... Density at the given point. C QP,QS...Powers of the P and S wave loss factors (the exponent of C the power is NEXPQ, see the input data for the model) at C the given point. C C Common block /MODELC/ (to use NEGPAR): INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: INTEGER LUWARN EXTERNAL LUWARN,ERROR,FPOWER,VAL2 C LUWARN,ERROR...File 'error.for'. C FPOWER...File 'model.for'. C VAL2... File 'val.for'. C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1999, August 16 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL FAUX(10,47),POWER(47),POWER1,POWER2,POWER3,POWER4,POWER5 EQUIVALENCE (POWER(1),POWER1),(POWER(2),POWER2),(POWER(3),POWER3) EQUIVALENCE (POWER(4),POWER4),(POWER(5),POWER5) REAL AUX(50) C C Constants: REAL C1,C2,C3,C4 PARAMETER (C1=1./15.,C2=2./15.,C3=3./15.,C4=4./15.) C C....................................................................... C CALL VAL2(2,IABS(ICB),47,COOR,FAUX,POWER) C C Velocities: IF(POWER1.NE.0.) THEN IF(FAUX(1,1).LE.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(10,FAUX(1,1),POWER1,UP) *V CALL VAR5(1,1) IF(POWER2.NE.0.) THEN IF(FAUX(1,2).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(10,FAUX(1,2),POWER2,US) *V CALL VAR5(2,2) ELSE DO 1 I=1,10 US(I)=0.57735*UP(I) 1 CONTINUE *V CALL VAR4(0,0.57735) *V CALL VAR5(2,1) END IF ELSE IF(POWER2.NE.0.) THEN IF(FAUX(1,2).LE.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(10,FAUX(1,2),POWER2,US) *V CALL VAR5(2,2) DO 2 I=1,10 UP(I)=1.73205*US(I) 2 CONTINUE *V CALL VAR4(0,1.73205) *V CALL VAR5(1,2) ELSE IF(POWER(06).NE.0..AND.POWER(07).NE.0..AND. * POWER(08).NE.0..AND.POWER(09).NE.0..AND. * POWER(10).NE.0..AND.POWER(11).NE.0..AND. * POWER(15).NE.0..AND.POWER(20).NE.0..AND. * POWER(26).NE.0.) THEN C Isotropic reference medium to the anisotropic material: CALL FPOWER(10,FAUX(1,06),.5*POWER(06),AUX(01)) CALL FPOWER(10,FAUX(1,08),.5*POWER(08),AUX(31)) CALL FPOWER(10,FAUX(1,11),.5*POWER(11),AUX(41)) CALL ADD10(AUX(01),AUX(31),AUX(41)) CALL FPOWER(10,FAUX(1,07),.5*POWER(07),AUX(11)) CALL FPOWER(10,FAUX(1,09),.5*POWER(09),AUX(31)) CALL FPOWER(10,FAUX(1,10),.5*POWER(10),AUX(41)) CALL ADD10(AUX(11),AUX(31),AUX(41)) CALL FPOWER(10,FAUX(1,15),.5*POWER(15),AUX(21)) CALL FPOWER(10,FAUX(1,20),.5*POWER(20),AUX(31)) CALL FPOWER(10,FAUX(1,26),.5*POWER(26),AUX(41)) CALL ADD10(AUX(21),AUX(31),AUX(41)) CALL LIN10(C3,AUX(01), C2,AUX(11),C4,AUX(21),AUX(31)) CALL LIN10(C1,AUX(01),-C1,AUX(11),C3,AUX(21),AUX(41)) CALL FPOWER(10,AUX(31),2.,UP) CALL FPOWER(10,AUX(41),2.,US) ELSE C 321 CALL ERROR('321 in PARM2: No velocity is defined') C Neither P nor S wave velocity in the current complex block C is defined in the input data. END IF END IF END IF C C Density: IF(POWER3.NE.0.) THEN IF(FAUX(1,3).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,3),POWER3,AUX) RHO=AUX(1) ELSE RHO=1. END IF C C Loss factors: IF(POWER4.NE.0.) THEN IF(FAUX(1,4).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,4),POWER4,AUX) QP=AUX(1) IF(POWER5.NE.0.) THEN IF(FAUX(1,5).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,5),POWER5,AUX) QS=AUX(1) ELSE IF(US(1).GT.0.) THEN QS=0.750000*QP*(UP(1)/US(1))**2 ELSE QS=0. END IF END IF ELSE IF(POWER5.NE.0.) THEN IF(FAUX(1,5).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,5),POWER5,AUX) QS=AUX(1) QP=1.333333*QS*(US(1)/UP(1))**2 ELSE QP=0. QS=0. END IF END IF RETURN C 9 CONTINUE WRITE(*,'('' X='',F9.3,'' Y='', * F9.3,'' Z='',F9.3/'' VP='',F7.3,'' VS='',F7.3,'' RO='', * F7.3,'' QP='',F7.3,'' QS='',F7.3)') COOR,(FAUX(1,I),I=1,5) IF(LUWARN(0).NE.0) THEN WRITE(LUWARN(0),'('' X='',F9.3,'' Y='', * F9.3,'' Z='',F9.3/'' VP='',F7.3,'' VS='',F7.3,'' RO='', * F7.3,'' QP='',F7.3,'' QS='',F7.3)') COOR,(FAUX(1,I),I=1,5) END IF C 322 CALL ERROR('322 in PARM2: Prohibited material parameter') C P wave velocity must be positive, other material parameters must C be non-negative. END C C----------------------------------------------------------------------- C C C SUBROUTINE ADD10(A,B,C) REAL A(10),B(10),C(10) C C Auxiliary subroutine to PARM2 summing 3 arrays of dimension 10. C C....................................................................... C INTEGER I C DO 10 I=1,10 A(I)=A(I)+B(I)+C(I) 10 CONTINUE RETURN END C C----------------------------------------------------------------------- C C C SUBROUTINE LIN10(C1,A1,C2,A2,C3,A3,A) REAL C1,A1(10),C2,A2(10),C3,A3(10),A(10) C C Auxiliary subroutine to PARM2 evaluating linear combination of C 3 arrays of dimension 10. C C....................................................................... C INTEGER I C DO 10 I=1,10 A(I)=C1*A1(I)+C2*A2(I)+C3*A3(I) 10 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE PARM3(ICB,COOR,A,RHO,Q) INTEGER ICB REAL COOR(3),A(10,21),RHO,Q(21) C C This subroutine is redundant for isotropic seismic models and codes. C C This subroutine evaluates 21 real parts of the reduced (divided by the C density) elastic parameters, 21 corresponding imaginary parts, and the C density at a given point. The three first and six second partial C derivatives of the 21 real parts of the reduced elastic parameters are C also evaluated. The specified functions are represented as a tensor C product of splines under tension. The parameters may be dependent C either on the general coordinates or on the distribution of another C parameter. The coefficients of these functions are prepared in C subroutine PARM1, in which the input data concerning the distribution C of individual parameters within each complex block are read in. C Variations of real parts of the reduced elastic parameters Aij with C respect to model parameters (evaluated by subroutines VAR*) are C stored in registers 6 to 26. C C Input: C ICB... Index of a complex block. C COOR... Array containing coordinates X1, X2, X3 of the given C point. C None of the input parameters are altered. C C Output: C A... Values, first and second partial derivatives of real C parts of 21 reduced (divided by the density) elastic C parameters. The order of the value, first and second C partial derivatives of each parameter Aij is: C Aij,Aij1,Aij2,Aij3,Aij11,Aij12,Aij22,Aij13,Aij23,Aij33. C The order of parameters (second array index) is: C A11,A12,A22,A13,A23,A33,A14,A24,A34,A44,A15,A25,A35,A45, C A55,A16,A26,A36,A46,A56,A66. C RHO... Density at the given point. C Q... Imaginary parts of 21 reduced elastic parameters at the C given point, ordered as C Q11,Q12,Q22,Q13,Q23,Q33,Q14,Q24,Q34,Q44,Q15,Q25,Q35,Q45, C Q55,Q16,Q26,Q36,Q46,Q56,Q66. C C----------------------------------------------------------------------- C C C C ENTRY PARM4(ISOFLG) INTEGER ISOFLG C C Entry of subroutine PARM3 answering whether the model is isotropic. C C No input. C C Output: C ISOFLG..ISOFLG=0: Anisotropic model. C ISOFLG=1: Isotropic model. C C Common block /MODELC/ (to use NEGPAR in PARM3 and BOUNDM in PARM4): INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL ERROR,FPOWER,VAL2 C ERROR...File 'error.for'. C FPOWER...File 'model.for'. C VAL2... File 'val.for'. C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1999, August 16 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER KA(21),IA,I,I1,I2,IERR REAL FAUX(10,47),POWER(47),POWER3,AUX(10) EQUIVALENCE (POWER(3),POWER3) C Order of processing the reduced elastic parameters: DATA KA/1,3,6,21,15,10,2,4,5,20,19,14,16,17,18,11,12,13,7,8,9/ C C....................................................................... C CALL VAL2(2,IABS(ICB),47,COOR,FAUX,POWER) C C Density: IF(POWER3.NE.0.) THEN IF(FAUX(1,3).LT.0.) THEN IERR=3 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(1,FAUX(1,3),POWER3,AUX) RHO=AUX(1) ELSE RHO=1. END IF C C Real-valued elastic parameters: DO 19 I2=1,21 IA=KA(I2) I=IA+5 IF(POWER(I).NE.0.) THEN C Element of the stiffness matrix is specified in the data: IERR=3 IF(I2.LE.6) THEN IF(I2.LE.3) THEN IF(FAUX(1,I).LE.0.) THEN IERR=I IF(NEGPAR.EQ.0) GO TO 49 END IF ELSE IF(FAUX(1,I).LT.0.) THEN IERR=I IF(NEGPAR.EQ.0) GO TO 49 END IF END IF END IF CALL FPOWER(10,FAUX(1,I),POWER(I),A(1,IA)) *V CALL VAR5(I,I) ELSE IF(I2.LE.3) THEN C Default diagonal stiffnesses A11,A22,A33: IF(POWER(1).NE.0.) THEN C Aij=VP*VP: IF(FAUX(1,1).LE.0.) THEN IERR=1 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) *V CALL VAR5(I,1) ELSE IF(POWER(2).NE.0.) THEN C Aij=3.*VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(2),A(1,IA)) *V CALL VAR5(I,2) DO 11 I1=1,10 A(I1,IA)=3.*A(I1,IA) 11 CONTINUE *V CALL VAR4(0,3.) *V CALL VAR5(I,I) ELSE C 323 CALL ERROR('323 in PARM3: Undefined elastic parameter') C If neither isotropic velocity VP nor VS is specified in the C input data, A11, A22 and A33 must be specified in order to C use this subroutine. END IF ELSE IF(I2.LE.6) THEN C Default diagonal stiffnesses A66,A55,A44: IF(POWER(2).NE.0.) THEN C Aij=VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(2),A(1,IA)) *V CALL VAR5(I,2) ELSE IF(POWER(1).NE.0.) THEN C Aij=.333333*VP*VP: IF(FAUX(1,1).LE.0.) THEN IERR=1 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) *V CALL VAR5(I,1) DO 12 I1=1,10 A(I1,IA)=.333333*A(I1,IA) 12 CONTINUE *V CALL VAR4(0,.333333) *V CALL VAR5(I,I) ELSE C 324 CALL ERROR('324 in PARM3: Undefined elastic parameter') C If neither isotropic velocity VP nor VS is specified in the C input data, A44, A55 and A66 must be specified in order to C use this subroutine. END IF ELSE IF(I2.LE.9) THEN C Default non-diagonal stiffnesses A12,A13,A23: IF(POWER(1).NE.0.) THEN IF(FAUX(1,1).LE.0.) THEN IERR=1 IF(NEGPAR.EQ.0) GO TO 49 END IF IF(POWER(2).NE.0.) THEN C Aij=VP*VP-2*VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(1),AUX) *V CALL VAR5(I,2) *V CALL VAR4(0,-2.) *V CALL VAR5(I,I) CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) *V CALL VAR5(I,1) DO 13 I1=1,10 A(I1,IA)=A(I1,IA)-2.*AUX(I1) 13 CONTINUE ELSE C Aij=.333333*VP*VP: CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) *V CALL VAR5(I,1) DO 14 I1=1,10 A(I1,IA)=.333333*A(I1,IA) 14 CONTINUE *V CALL VAR4(0,.333333) *V CALL VAR5(I,I) END IF ELSE IF(POWER(2).NE.0.) THEN C Aij=VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(2),A(1,IA)) *V CALL VAR5(I,2) ELSE C 325 CALL ERROR('325 in PARM3: Undefined elastic parameter') C If neither isotropic velocity VP nor VS is specified in C the input data, A45, A46 and A56 must be specified in C order to use this subroutine. END IF END IF ELSE C Default non-diagonal stiffnesses C A56,A46,A45,A16,A26,A36,A15,A25,A35,A14,A24,A34: DO 18 I1=1,10 A(I1,IA)=0. 18 CONTINUE END IF 19 CONTINUE C C Imaginary parts of the elastic parameters: DO 29 I2=1,21 I=I2+26 IF(POWER(I).NE.0.) THEN IF(I2.LE.6) THEN IF(FAUX(1,I).LT.0.) THEN IERR=I IF(NEGPAR.EQ.0) GO TO 49 END IF END IF CALL FPOWER(1,FAUX(1,I),POWER(I),Q(I2)) ELSE C Default: Q(I2)=0. END IF 29 CONTINUE C C Check for positive semidefinitness: C *** not coded *** C Error 327: Prohibited elastic parameter: C Both real and imaginary parts of the 6*6 matrix of elastic C parameters (stiffness matrix) must be positively C semi-definite, and the 3*3 upper-left minor of its real C part must be positively definite. The density must be C positive. RETURN C 49 CONTINUE WRITE(*,'('' X='',F9.3,'' Y='',F9.3,'' Z='',F9.3, * '' FAUX(1,'',I2,'')='',F7.3)') COOR,IERR,FAUX(1,IERR) C 326 CALL ERROR('326 in PARM3: Prohibited elastic parameter') C Following parameters must be positive: C FAUX(1, 1)=VP **POWER( 1) C FAUX(1, 6)=A11**POWER( 6) C FAUX(1, 8)=A22**POWER( 8) C FAUX(1,11)=A33**POWER(11) C Following parameters must be non-negative: C FAUX(1, 2)=VS **POWER( 2) C FAUX(1, 3)=RHO**POWER( 3) C FAUX(1,15)=A44**POWER(15) C FAUX(1,20)=A55**POWER(20) C FAUX(1,26)=A66**POWER(26) C FAUX(1,27)=Q11**POWER(27) C FAUX(1,29)=Q22**POWER(29) C FAUX(1,32)=Q33**POWER(32) C FAUX(1,36)=Q44**POWER(36) C FAUX(1,41)=Q55**POWER(41) C FAUX(1,47)=Q66**POWER(47) RETURN C C----------------------------------------------------------------------- C ENTRY PARM4(ISOFLG) C ISOFLG=1 AUX(1)=(BOUNDM(1)+BOUNDM(2))/2. AUX(2)=(BOUNDM(3)+BOUNDM(4))/2. AUX(3)=(BOUNDM(5)+BOUNDM(6))/2. DO 62 I2=1,NCB CALL VAL2(2,I2,47,AUX,FAUX,POWER) DO 61 I1=5,47 IF(POWER(I1).NE.0.) THEN ISOFLG=0 END IF 61 CONTINUE 62 CONTINUE RETURN END C C======================================================================= Cparmv.for 0100666 0000765 0000765 00000114010 07041770500 012263 0 ustar bulant bulant CC Subroutine file 'parm.for' for specification and interpolation of the C material parameters of the model in rectangular grids. C C Date: 1999, August 18 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C PARM1...Subroutine reading the input data for the material C parameters of the model. C PARM1 C PARM2...Subroutine evaluating the isotropic material parameters C including their first and second derivatives. C The functions may be embedded: the independent variable C of the function may be another material parameter of the C same complex block foregoing in the input data. C PARM2 C ADD10...Auxiliary subroutine to PARM2 summing 3 arrays of C dimension 10. C ADD10 C LIN10...Auxiliary subroutine to PARM2 evaluating the linear C combination of 3 arrays of dimension 10. C LIN10 C PARM3...Subroutine evaluating the anisotropic material parameters C including their first and second derivatives. C PARM3 C PARM4...Entry of subroutine PARM3 answering whether the model is C isotropic or anisotropic. C PARM4 C Subroutines PARM1, PARM2, and PARM3, supporting isotropic complete ray C tracing algorithm, anisotropic ray tracing and other seismic modelling C algorithms, only mediate the work of subroutines VAL1, VAL2 and FPOWER C which must be appended. In addition, subroutines CURVN1 (or its C alternative CURVB1), CURV2D (or its alternative CURVBD), SURFB1, C SURFBD, VAL3B1, VAL3BD, VGEN, TERMS, SNHCSH, TRIDEC, TRISOL, DSPLNZ, C INTRVL from the subroutine package 'FITPACK' by Alan Kaylor Cline, C Department of Computer Sciences, University of Texas at Austin, are C used. In the complete ray tracing, this software file 'parm.for' may C be replaced by any user-defined package containing subroutines PARM1 C and PARM2 with the same number, type and meaning of their parameters C as in this file. C C Note: C The lines denoted by '*V' in the first two columns of file C 'parm.for' are designed to calculate the model variations with C respect to the model parameters. C File 'parmv.for', intended for the model inversion, is created C from 'parm.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C C If model variations are taken into account: C Model variations are assumed to be stored while evaluating the C functions during the invocation of subroutine VAL of file C 'val.for' and subsequent routines of file 'fit.for'. C The variations of P-wave velocity are assumed to be stored in C register 1 of the system VAR*, the variations of S-wave velocity C are assumed to be stored in register 2 of the system VAR*. C Variations of the density and loss (or quality) factors are not C considered, although they may be stored in other registers. C Subroutines VAR4 and VAR5 are called within the subroutine PARM2 C in order to deal with the variations of P and S wave velocities. C C....................................................................... C C C Input data (read in by subroutine PARM1): C These input data define the complex blocks. They are read in by C subroutine PARM1. The number NCB of the complex blocks to be C defined is an input argument of subroutine PARM1. The data are C read in by the list directed input (free format). C (1) NCB-times (i.e. once for each complex block) input data (1A)+(1B): C (1A) TEXTG,ICB C Identification of the complex block. C TEXTG...Any string. Its first 3 characters must differ from C 'VP ', 'VS ', 'DEN', 'QP ', 'QS ', C 'A11', 'A12', 'A22', 'A13', 'A23', 'A33', 'A14', 'A24', C 'A34', 'A44', 'A15', 'A25', 'A35', 'A45', 'A55', 'A16', C 'A26', 'A36', 'A46', 'A56', 'A66', C 'B11', 'B12', 'B22', 'B13', 'B23', 'B33', 'B14', 'B24', C 'B34', 'B44', 'B15', 'B25', 'B35', 'B45', 'B55', 'B16', C 'B26', 'B36', 'B46', 'B56', 'B66', C 'Q11', 'Q12', 'Q22', 'Q13', 'Q23', 'Q33', 'Q14', 'Q24', C 'Q34', 'Q44', 'Q15', 'Q25', 'Q35', 'Q45', 'Q55', 'Q16', C 'Q26', 'Q36', 'Q46', 'Q56', 'Q66', 'END'. C ICB... Index of the complex block. C (1B) Several times 'Input data for one material parameter', see below. C Isotropic complex block: C At least one of velocities 'VP ' and 'VS ' must be specified. C Unspecified isotropic elastic parameters ('VP ', 'VS ', 'QP ', C 'QS ') take their default values. Anisotropic elastic C parameters correspond to the isotropic medium. C Anisotropic complex block with given isotropic reference medium: C Isotropic complex block with one to all anisotropic elastic C parameters specified. Unspecified anisotropic elastic C parameters default to the isotropic medium. C Anisotropic complex block: C At least 9 reduced anisotropic elastic parameters 'A11', 'A12', C 'A22', 'A13', 'A23', 'A33', 'A44', 'A55', and 'A66' must be C specified in the anisotropic complex block. Unspecified C anisotropic elastic parameters default to zeros. C (2) TEXTE,AUX C End of data. C TEXTE...String, the first 3 characters of which must be upper-case C 'END'. C AUX... Any number or a slash. C For an example refer to the sample input data for the model. C C Input data for one material parameter: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new read statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise (except TEXTF), the input parameter is of the C type REAL. C (1) TEXTF,POWER C Physical meaning of the function. C TEXTF...String identifying which material parameter the function C describes. Only the first 3 characters are significant. C The first 3 characters of the string must be: C 'VP ' for P wave velocity, C 'VS ' for S wave velocity, C 'DEN' for density, C 'QP ' for P wave loss factor, C 'QS ' for S wave loss factor. C 'A11', 'A12', 'A22', 'A13', 'A23', 'A33', 'A14', 'A24', C 'A34', 'A44', 'A15', 'A25', 'A35', 'A45', 'A55', 'A16', C 'A26', 'A36', 'A46', 'A56', or 'A66' for reduced (i.e. C divided by the density) anisotropic elastic parameters C (components of the real part of the symmetric 6*6 C stiffness matrix divided by the density). C 'Q11', 'Q12', 'Q22', 'Q13', 'Q23', 'Q33', 'Q14', 'Q24', C 'Q34', 'Q44', 'Q15', 'Q25', 'Q35', 'Q45', 'Q55', 'Q16', C 'Q26', 'Q36', 'Q46', 'Q56', or 'Q66' for reduced (i.e. C divided by the density) imaginary anisotropic elastic C parameters (components of the imaginary part of the C symmetric 6*6 stiffness matrix divided by the density). C All strings must be entered in uppercase. C POWER...The specified function is equal to the POWER-th power of C the material parameter. C Examples: C For P wave velocity TEXTF='VP ' and POWER=1.0, C for P wave slowness TEXTF='VP ' and POWER=-1.0, C for S wave quadratic slowness TEXTF='VS ' and C POWER=-2.0, C for P wave loss factor TEXTF='QP ' and POWER=1.0, C for S wave quality factor TEXTF='QS ' and POWER=-1.0. C Default values of isotropic elastic parameters not specified in C the input data (subroutine PARM2): C Isotropic complex block or anisotropic complex block with C given isotropic reference medium (at least one of VP and C VS given): C P wave velocity: VP=1.73205*VS, C S wave velocity: VS=0.57735*VP, C Anisotropic complex block (neither VP nor VS given): C Default isotropic parameters are expressed in terms of C anisotropic parameters to allow for application of the C isotropic code to anisotropic models. C Average isotropic medium minimizing the squared norm of C the difference between the Christoffel matrices, C averaged over propagation directions: C AP=A11+A22+A33, C AL=A12+A13+A23, C AS=A44+A55+A66, C VP=SQRT( (3.*AP+2.*AL+4.*AS)/15 ), C VS=SQRT( ( AP - AL+3.*AS)/15 ), C This reference isotropic medium is designed especially C to serve as a basis for anisotropic perturbations. From C this point of view, the variations of the these default C isotropic material parameters with respect to the model C parameters, evaluated by means of subroutines VAR*, are C unnecessary. No variations of the above defaults are C thus set in PARM2. C In any case: C Density: RHO=1, C P wave loss factor (if S wave loss factor is specified): C QP=1.333333*QS*(US(1)/UP(1))**2, C S wave loss factor (if P wave loss factor is specified): C QS=0.750000*QP*(UP(1)/US(1))**2, C P and S wave loss factors (if none of them is given): C QP=0.0, QS=0.0. C Default values of anisotropic elastic parameters not specified in C the input data (subroutine PARM3): C Isotropic complex block or anisotropic complex block with C given isotropic reference medium (at least one of VP and C VS given): C Default anisotropic parameters are expressed in terms of C isotropic parameters for the sake of continuity with C isotropic models: C A11=A22=A33= VP*VP, C A12=A13=A23= VP*VP-2*VS*VS, C A44=A55=A66= VS*VS, C A14=A24=A34=A15=A25=A35=A45=A16=A26=A36=A46=A56= 0. C Anisotropic complex block (neither VP nor VS given): C Aij=0. C In any case: C RHO=1, C Qij=0 in this version. C (2) IVAR1,IVAR2,IVAR3,SIGMA,POWERW,/ C The form of the function. C IVAR1,IVAR2,IVAR3... Denote the form of the function. The function C must be of the form C F(X1,X2,X3) = W(A1,A2,A3)-B1-B2-B3 . C X1, X2, X3 are the general coordinates. Each of A1, A2, C A3, B1, B2, B3 must be either: (a) one of general C coordinates X1, X2, X3, (b) another previously defined C function F(X1,X2,X3) of the same complex block, or (c) C must be left out. At most 3 of parameters A1-B3 may be of C kind (a) or (b). Note that IVAR1 controls the type of A1 C and B1, IVAR2 controls the type of A2 and B2, IVAR3 C controls the type of A3 and B3. C For IVAR1.EQ.0: A1, B1 are empty (left out). C For IVAR1.EQ.1: A1=X1, B1 is empty. C For IVAR1.EQ.2: A1=X2, B1 is empty. C For IVAR1.EQ.3: A1=X3, B1 is empty. C For IVAR1.GE.4: A1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same complex block defined in C the input data as the (IVAR1-3)-th function of the C complex block. B1 is empty. C Example: C If density=1.7+0.2*VP then the interpolated function C is W(A1,A2,A3)=1.7+0.2*A1 with the independent C variable A1=VP(X1,X2,X3). This is specified by C IVAR1=4, IVAR2=0, IVAR3=0 if VP is the first read in C parameter, by IVAR1=5, IVAR2=0, IVAR3=0 if VP is the C second read in parameter, etc. C The possible alternatives are W(A1,A2,A3)=1.7+0.2*A2 C with A2=VP(X1,X2,X3) specified by IVAR1=0, C IVAR2=(4 or 5 or the like), IVAR3=0, and C W(A1,A2,A3)=1.7+0.2*A3 with A3=VP(X1,X2,X3) specified C by IVAR1=0, IVAR3=2, IVAR3=(4 or 5 or the like). C For IVAR1.EQ.-1: B1=X1, A1 is empty. C For IVAR1.EQ.-2: B1=X2, A1 is empty. C For IVAR1.EQ.-3: B1=X3, A1 is empty. C For IVAR1.GE.-4: B1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same complex block defined in C the input data as the (-IVAR1-3)-th function of the C complex block. A1 is empty. C The meaning of the parameters IVAR2, IVAR3 is similar. C Examples: C IVAR1: IVAR2: IVAR3: the form of the function: C 1 2 3 F(X1,X2,X3)=W(X1,X2,X3) C 3 1 2 F(X1,X2,X3)=W(X3,X1,X2) C 1 2 0 F(X1,X2,X3)=W(X1,X2) C 5 0 0 F(X1,X2,X3)=W(F2(X1,X2,X3)), where C F2(X1,X2,X3) is the second material parameter of the C complex block defined in the input data. Function W is C interpolated by means of splines under tension. C SIGMA...Is the tension factor (its sign is ignored). This value C indicates the curviness desired. If ABS(SIGMA) is nearly C zero (e.g. 0.001), the resulting surface is approximately C the tensor product of cubic splines. If ABS(SIGMA) is C large (e.g. 50.), the resulting surface is approximately C tri-linear. If SIGMA equals zero, tensor products of C cubic splines result. A recommended value for SIGMA is C approximately 1. In absolute value. C POWERW..Given grid values (7) correspond to the POWERW-th power of C interpolated function W. The given grid values (7) are C thus raised to the (1/POWERW)-th power immediately after C reading and then interpolated. C /... Obligatory slash at the end of line for future extensions. C Default: IVAR1=0, IVAR2=0, IVAR3=0, SIGMA=0, POWERW=1. C (3) NX(1),...,NX(NVAR) C The numbers of grid coordinates for the interpolation. C This input is performed if at least one of IVAR1, IVAR2, IVAR3 is C positive. C Each of NX(1),...,NX(NVAR) corresponds to one positive value of C IVAR1, IVAR2, IVAR3 and specifies the number of grid coordinates C corresponding to that independent variable of function W, see (2). C The sign of NX(1),...,NX(NVAR) is ignored. NVAR (.LE.3) is the C number of positive values of the above quantities IVAR1, IVAR2, C IVAR3, i.e. the number of independent variables of function W, C see (1). C (4) X1(1),...,X1(NX(1)) C The grid coordinates corresponding to the first independent C variable of function W, see (2). C This input is performed if NX(1) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (5) X2(1),...,X2(NX(2)) C The grid coordinates corresponding to the second independent C variable of function W, see (2). C This input is performed if NX(2) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (6) X3(1),...,X3(NX(3)) C The grid coordinates corresponding to the third independent C variable of function W, see (2). C This input is performed if NX(3) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (7) (((W(I,J,K),I=1,MAX(NX(1),1)),J=1,MAX(NX(2),1)),K=1,MAX(NX(3),1)) C the values of function W at grid points. Function value W(i,j,k) C corresponds to point (X1(I),X2(J),X3(K)). C C======================================================================= C C C SUBROUTINE PARM1(LUN,NCB) INTEGER LUN,NCB C C This subroutine reads the input data for the distributions of the C material parameters: C In the isotropic complex blocks: C P and S wave velocities, density, P and S wave loss factors C in the anisotropic complex blocks: C 21 real parts of the reduced (divided by the density) elastic C parameters, 21 corresponding imaginary parts, density. C Reference isotropic P and S velocities and loss factors may also be C specified together with anisotropic material parameters. C When reading the data, subroutine PARM1 also determines the parameters C necessary to compute an interpolatory function on a three dimensional C rectangular grid, and stores them in the memory. The function C determined can be represented as a tensor product of splines under C tension. The functions may be embedded. For actual interpolation of C material parameters it is necessary to call subroutine PARM2 for C isotropic model (or mean isotropic model corresponding to the C anisotropic model), or subroutine PARM3 for anisotropic material C parameters of the isotropic or anisotropic model. Subroutines PARM2 C and PARM3 also return the first and second partial derivatives of C propagation velocities or reduced elastic parameters. Subroutine C PARM1 may be called several times. The complex blocks are indexed C successively, following the complex blocks defined during the previous C invocations. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C NCB... Number of the material complex blocks for which the input C data are specified during the current invocation of PARM1. C None of the input parameters are altered. C C No output. C C Subroutines and external functions required: EXTERNAL VAL1 C VAL1, SORTV, READV... File 'val.for'. C CURVN1 or CURVB1 (alternatives), SURFB1, VAL3B1, SNHCSH, VGEN, C TERMS, TRIDEC, TRISOL... Subroutine package 'FITPACK' C (file 'fit.for'). C C Date: 1995, December 17 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: CHARACTER*3 TFUNCT(47) DATA TFUNCT/'VP ','VS ','DEN','QP ','QS ', *'A11','A12','A22','A13','A23','A33','A14','A24','A34','A44', *'A15','A25','A35','A45','A55','A16','A26','A36','A46','A56','A66', *'Q11','Q12','Q22','Q13','Q23','Q33','Q14','Q24','Q34','Q44', *'Q15','Q25','Q35','Q45','Q55','Q16','Q26','Q36','Q46','Q56','Q66'/ C CALL VAL1(LUN,2,NCB,47,TFUNCT) RETURN END C C======================================================================= C C C SUBROUTINE PARM2(ICB,COOR,UP,US,RHO,QP,QS) INTEGER ICB REAL COOR(3),UP(10),US(10),RHO,QP,QS C C This subroutine evaluates P and S wave velocities, density, and P and C S wave loss factors at a given point. The three first and six second C partial derivatives of the velocities are also evaluated. The C specified functions are represented as a tensor product of splines C under tension. The parameters may be dependent either on the general C coordinates or on the distribution of another parameter, e.g. C VS=0.577*VP or RHO=1.7+0.2*VP, where VP, VS and RHO are P and S C velocities and density. The coefficients of these functions are C prepared in subroutine PARM1, in which the input data concerning the C distribution of individual parameters within each complex block are C read in. The default values of parameters not specified in the input C data are: C P wave velocity: VP=1.73205*VS, C S wave velocity: VS=0.57735*VP, C Density: RHO=1.0, C P wave loss factor (if the S wave loss factor is specified): C QP=1.333333*QS*(US(1)/UP(1))**2, C S wave loss factor (if the P wave loss factor is specified): C QS=0.750000*QP*(UP(1)/US(1))**2, C P and S wave loss factors (if none of them is specified): C QP=0.0, QS=0.0. C Attention: The above default values are reasonable only if arguments C UP and US of this subroutine are velocities, and QP and QS loss C factors. In other words, these default settings are useful only C if NEXPV=1 and NEXPQ=1 in the input data set model, line (2). C Note that at least one of the velocities must be specified in the C input data. P wave velocity must be positive, other material C parameters must be non-negative. C C Input: C ICB... Index of a complex block. C COOR... Array containing coordinates X1, X2, X3 of the given C point. C None of the input parameters are altered. C C Output: C UP,US...Powers of the P and S wave velocities (the exponent of the C power is NEXPV, see the input data for the model) and C their first and second partial derivatives in order U, U1, C U2, U3, U11, U12, U22, U13, U23, U33, at the given point. C RHO... Density at the given point. C QP,QS...Powers of the P and S wave loss factors (the exponent of C the power is NEXPQ, see the input data for the model) at C the given point. C C Common block /MODELC/ (to use NEGPAR): INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: INTEGER LUWARN EXTERNAL LUWARN,ERROR,FPOWER,VAL2 C LUWARN,ERROR...File 'error.for'. C FPOWER...File 'model.for'. C VAL2... File 'val.for'. C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1999, August 16 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL FAUX(10,47),POWER(47),POWER1,POWER2,POWER3,POWER4,POWER5 EQUIVALENCE (POWER(1),POWER1),(POWER(2),POWER2),(POWER(3),POWER3) EQUIVALENCE (POWER(4),POWER4),(POWER(5),POWER5) REAL AUX(50) C C Constants: REAL C1,C2,C3,C4 PARAMETER (C1=1./15.,C2=2./15.,C3=3./15.,C4=4./15.) C C....................................................................... C CALL VAL2(2,IABS(ICB),47,COOR,FAUX,POWER) C C Velocities: IF(POWER1.NE.0.) THEN IF(FAUX(1,1).LE.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(10,FAUX(1,1),POWER1,UP) CALL VAR5(1,1) IF(POWER2.NE.0.) THEN IF(FAUX(1,2).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(10,FAUX(1,2),POWER2,US) CALL VAR5(2,2) ELSE DO 1 I=1,10 US(I)=0.57735*UP(I) 1 CONTINUE CALL VAR4(0,0.57735) CALL VAR5(2,1) END IF ELSE IF(POWER2.NE.0.) THEN IF(FAUX(1,2).LE.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(10,FAUX(1,2),POWER2,US) CALL VAR5(2,2) DO 2 I=1,10 UP(I)=1.73205*US(I) 2 CONTINUE CALL VAR4(0,1.73205) CALL VAR5(1,2) ELSE IF(POWER(06).NE.0..AND.POWER(07).NE.0..AND. * POWER(08).NE.0..AND.POWER(09).NE.0..AND. * POWER(10).NE.0..AND.POWER(11).NE.0..AND. * POWER(15).NE.0..AND.POWER(20).NE.0..AND. * POWER(26).NE.0.) THEN C Isotropic reference medium to the anisotropic material: CALL FPOWER(10,FAUX(1,06),.5*POWER(06),AUX(01)) CALL FPOWER(10,FAUX(1,08),.5*POWER(08),AUX(31)) CALL FPOWER(10,FAUX(1,11),.5*POWER(11),AUX(41)) CALL ADD10(AUX(01),AUX(31),AUX(41)) CALL FPOWER(10,FAUX(1,07),.5*POWER(07),AUX(11)) CALL FPOWER(10,FAUX(1,09),.5*POWER(09),AUX(31)) CALL FPOWER(10,FAUX(1,10),.5*POWER(10),AUX(41)) CALL ADD10(AUX(11),AUX(31),AUX(41)) CALL FPOWER(10,FAUX(1,15),.5*POWER(15),AUX(21)) CALL FPOWER(10,FAUX(1,20),.5*POWER(20),AUX(31)) CALL FPOWER(10,FAUX(1,26),.5*POWER(26),AUX(41)) CALL ADD10(AUX(21),AUX(31),AUX(41)) CALL LIN10(C3,AUX(01), C2,AUX(11),C4,AUX(21),AUX(31)) CALL LIN10(C1,AUX(01),-C1,AUX(11),C3,AUX(21),AUX(41)) CALL FPOWER(10,AUX(31),2.,UP) CALL FPOWER(10,AUX(41),2.,US) ELSE C 321 CALL ERROR('321 in PARM2: No velocity is defined') C Neither P nor S wave velocity in the current complex block C is defined in the input data. END IF END IF END IF C C Density: IF(POWER3.NE.0.) THEN IF(FAUX(1,3).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,3),POWER3,AUX) RHO=AUX(1) ELSE RHO=1. END IF C C Loss factors: IF(POWER4.NE.0.) THEN IF(FAUX(1,4).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,4),POWER4,AUX) QP=AUX(1) IF(POWER5.NE.0.) THEN IF(FAUX(1,5).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,5),POWER5,AUX) QS=AUX(1) ELSE IF(US(1).GT.0.) THEN QS=0.750000*QP*(UP(1)/US(1))**2 ELSE QS=0. END IF END IF ELSE IF(POWER5.NE.0.) THEN IF(FAUX(1,5).LT.0.) THEN IF(NEGPAR.EQ.0) GO TO 9 END IF CALL FPOWER(1,FAUX(1,5),POWER5,AUX) QS=AUX(1) QP=1.333333*QS*(US(1)/UP(1))**2 ELSE QP=0. QS=0. END IF END IF RETURN C 9 CONTINUE WRITE(*,'('' X='',F9.3,'' Y='', * F9.3,'' Z='',F9.3/'' VP='',F7.3,'' VS='',F7.3,'' RO='', * F7.3,'' QP='',F7.3,'' QS='',F7.3)') COOR,(FAUX(1,I),I=1,5) IF(LUWARN(0).NE.0) THEN WRITE(LUWARN(0),'('' X='',F9.3,'' Y='', * F9.3,'' Z='',F9.3/'' VP='',F7.3,'' VS='',F7.3,'' RO='', * F7.3,'' QP='',F7.3,'' QS='',F7.3)') COOR,(FAUX(1,I),I=1,5) END IF C 322 CALL ERROR('322 in PARM2: Prohibited material parameter') C P wave velocity must be positive, other material parameters must C be non-negative. END C C----------------------------------------------------------------------- C C C SUBROUTINE ADD10(A,B,C) REAL A(10),B(10),C(10) C C Auxiliary subroutine to PARM2 summing 3 arrays of dimension 10. C C....................................................................... C INTEGER I C DO 10 I=1,10 A(I)=A(I)+B(I)+C(I) 10 CONTINUE RETURN END C C----------------------------------------------------------------------- C C C SUBROUTINE LIN10(C1,A1,C2,A2,C3,A3,A) REAL C1,A1(10),C2,A2(10),C3,A3(10),A(10) C C Auxiliary subroutine to PARM2 evaluating linear combination of C 3 arrays of dimension 10. C C....................................................................... C INTEGER I C DO 10 I=1,10 A(I)=C1*A1(I)+C2*A2(I)+C3*A3(I) 10 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE PARM3(ICB,COOR,A,RHO,Q) INTEGER ICB REAL COOR(3),A(10,21),RHO,Q(21) C C This subroutine is redundant for isotropic seismic models and codes. C C This subroutine evaluates 21 real parts of the reduced (divided by the C density) elastic parameters, 21 corresponding imaginary parts, and the C density at a given point. The three first and six second partial C derivatives of the 21 real parts of the reduced elastic parameters are C also evaluated. The specified functions are represented as a tensor C product of splines under tension. The parameters may be dependent C either on the general coordinates or on the distribution of another C parameter. The coefficients of these functions are prepared in C subroutine PARM1, in which the input data concerning the distribution C of individual parameters within each complex block are read in. C Variations of real parts of the reduced elastic parameters Aij with C respect to model parameters (evaluated by subroutines VAR*) are C stored in registers 6 to 26. C C Input: C ICB... Index of a complex block. C COOR... Array containing coordinates X1, X2, X3 of the given C point. C None of the input parameters are altered. C C Output: C A... Values, first and second partial derivatives of real C parts of 21 reduced (divided by the density) elastic C parameters. The order of the value, first and second C partial derivatives of each parameter Aij is: C Aij,Aij1,Aij2,Aij3,Aij11,Aij12,Aij22,Aij13,Aij23,Aij33. C The order of parameters (second array index) is: C A11,A12,A22,A13,A23,A33,A14,A24,A34,A44,A15,A25,A35,A45, C A55,A16,A26,A36,A46,A56,A66. C RHO... Density at the given point. C Q... Imaginary parts of 21 reduced elastic parameters at the C given point, ordered as C Q11,Q12,Q22,Q13,Q23,Q33,Q14,Q24,Q34,Q44,Q15,Q25,Q35,Q45, C Q55,Q16,Q26,Q36,Q46,Q56,Q66. C C----------------------------------------------------------------------- C C C C ENTRY PARM4(ISOFLG) INTEGER ISOFLG C C Entry of subroutine PARM3 answering whether the model is isotropic. C C No input. C C Output: C ISOFLG..ISOFLG=0: Anisotropic model. C ISOFLG=1: Isotropic model. C C Common block /MODELC/ (to use NEGPAR in PARM3 and BOUNDM in PARM4): INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL ERROR,FPOWER,VAL2 C ERROR...File 'error.for'. C FPOWER...File 'model.for'. C VAL2... File 'val.for'. C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1999, August 16 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER KA(21),IA,I,I1,I2,IERR REAL FAUX(10,47),POWER(47),POWER3,AUX(10) EQUIVALENCE (POWER(3),POWER3) C Order of processing the reduced elastic parameters: DATA KA/1,3,6,21,15,10,2,4,5,20,19,14,16,17,18,11,12,13,7,8,9/ C C....................................................................... C CALL VAL2(2,IABS(ICB),47,COOR,FAUX,POWER) C C Density: IF(POWER3.NE.0.) THEN IF(FAUX(1,3).LT.0.) THEN IERR=3 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(1,FAUX(1,3),POWER3,AUX) RHO=AUX(1) ELSE RHO=1. END IF C C Real-valued elastic parameters: DO 19 I2=1,21 IA=KA(I2) I=IA+5 IF(POWER(I).NE.0.) THEN C Element of the stiffness matrix is specified in the data: IERR=3 IF(I2.LE.6) THEN IF(I2.LE.3) THEN IF(FAUX(1,I).LE.0.) THEN IERR=I IF(NEGPAR.EQ.0) GO TO 49 END IF ELSE IF(FAUX(1,I).LT.0.) THEN IERR=I IF(NEGPAR.EQ.0) GO TO 49 END IF END IF END IF CALL FPOWER(10,FAUX(1,I),POWER(I),A(1,IA)) CALL VAR5(I,I) ELSE IF(I2.LE.3) THEN C Default diagonal stiffnesses A11,A22,A33: IF(POWER(1).NE.0.) THEN C Aij=VP*VP: IF(FAUX(1,1).LE.0.) THEN IERR=1 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) CALL VAR5(I,1) ELSE IF(POWER(2).NE.0.) THEN C Aij=3.*VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(2),A(1,IA)) CALL VAR5(I,2) DO 11 I1=1,10 A(I1,IA)=3.*A(I1,IA) 11 CONTINUE CALL VAR4(0,3.) CALL VAR5(I,I) ELSE C 323 CALL ERROR('323 in PARM3: Undefined elastic parameter') C If neither isotropic velocity VP nor VS is specified in the C input data, A11, A22 and A33 must be specified in order to C use this subroutine. END IF ELSE IF(I2.LE.6) THEN C Default diagonal stiffnesses A66,A55,A44: IF(POWER(2).NE.0.) THEN C Aij=VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(2),A(1,IA)) CALL VAR5(I,2) ELSE IF(POWER(1).NE.0.) THEN C Aij=.333333*VP*VP: IF(FAUX(1,1).LE.0.) THEN IERR=1 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) CALL VAR5(I,1) DO 12 I1=1,10 A(I1,IA)=.333333*A(I1,IA) 12 CONTINUE CALL VAR4(0,.333333) CALL VAR5(I,I) ELSE C 324 CALL ERROR('324 in PARM3: Undefined elastic parameter') C If neither isotropic velocity VP nor VS is specified in the C input data, A44, A55 and A66 must be specified in order to C use this subroutine. END IF ELSE IF(I2.LE.9) THEN C Default non-diagonal stiffnesses A12,A13,A23: IF(POWER(1).NE.0.) THEN IF(FAUX(1,1).LE.0.) THEN IERR=1 IF(NEGPAR.EQ.0) GO TO 49 END IF IF(POWER(2).NE.0.) THEN C Aij=VP*VP-2*VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(1),AUX) CALL VAR5(I,2) CALL VAR4(0,-2.) CALL VAR5(I,I) CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) CALL VAR5(I,1) DO 13 I1=1,10 A(I1,IA)=A(I1,IA)-2.*AUX(I1) 13 CONTINUE ELSE C Aij=.333333*VP*VP: CALL FPOWER(10,FAUX(1,1),0.5*POWER(1),A(1,IA)) CALL VAR5(I,1) DO 14 I1=1,10 A(I1,IA)=.333333*A(I1,IA) 14 CONTINUE CALL VAR4(0,.333333) CALL VAR5(I,I) END IF ELSE IF(POWER(2).NE.0.) THEN C Aij=VS*VS: IF(FAUX(1,2).LT.0.) THEN IERR=2 IF(NEGPAR.EQ.0) GO TO 49 END IF CALL FPOWER(10,FAUX(1,2),0.5*POWER(2),A(1,IA)) CALL VAR5(I,2) ELSE C 325 CALL ERROR('325 in PARM3: Undefined elastic parameter') C If neither isotropic velocity VP nor VS is specified in C the input data, A45, A46 and A56 must be specified in C order to use this subroutine. END IF END IF ELSE C Default non-diagonal stiffnesses C A56,A46,A45,A16,A26,A36,A15,A25,A35,A14,A24,A34: DO 18 I1=1,10 A(I1,IA)=0. 18 CONTINUE END IF 19 CONTINUE C C Imaginary parts of the elastic parameters: DO 29 I2=1,21 I=I2+26 IF(POWER(I).NE.0.) THEN IF(I2.LE.6) THEN IF(FAUX(1,I).LT.0.) THEN IERR=I IF(NEGPAR.EQ.0) GO TO 49 END IF END IF CALL FPOWER(1,FAUX(1,I),POWER(I),Q(I2)) ELSE C Default: Q(I2)=0. END IF 29 CONTINUE C C Check for positive semidefinitness: C *** not coded *** C Error 327: Prohibited elastic parameter: C Both real and imaginary parts of the 6*6 matrix of elastic C parameters (stiffness matrix) must be positively C semi-definite, and the 3*3 upper-left minor of its real C part must be positively definite. The density must be C positive. RETURN C 49 CONTINUE WRITE(*,'('' X='',F9.3,'' Y='',F9.3,'' Z='',F9.3, * '' FAUX(1,'',I2,'')='',F7.3)') COOR,IERR,FAUX(1,IERR) C 326 CALL ERROR('326 in PARM3: Prohibited elastic parameter') C Following parameters must be positive: C FAUX(1, 1)=VP **POWER( 1) C FAUX(1, 6)=A11**POWER( 6) C FAUX(1, 8)=A22**POWER( 8) C FAUX(1,11)=A33**POWER(11) C Following parameters must be non-negative: C FAUX(1, 2)=VS **POWER( 2) C FAUX(1, 3)=RHO**POWER( 3) C FAUX(1,15)=A44**POWER(15) C FAUX(1,20)=A55**POWER(20) C FAUX(1,26)=A66**POWER(26) C FAUX(1,27)=Q11**POWER(27) C FAUX(1,29)=Q22**POWER(29) C FAUX(1,32)=Q33**POWER(32) C FAUX(1,36)=Q44**POWER(36) C FAUX(1,41)=Q55**POWER(41) C FAUX(1,47)=Q66**POWER(47) RETURN C C----------------------------------------------------------------------- C ENTRY PARM4(ISOFLG) C ISOFLG=1 AUX(1)=(BOUNDM(1)+BOUNDM(2))/2. AUX(2)=(BOUNDM(3)+BOUNDM(4))/2. AUX(3)=(BOUNDM(5)+BOUNDM(6))/2. DO 62 I2=1,NCB CALL VAL2(2,I2,47,AUX,FAUX,POWER) DO 61 I1=5,47 IF(POWER(I1).NE.0.) THEN ISOFLG=0 END IF 61 CONTINUE 62 CONTINUE RETURN END C C======================================================================= Crkgs.for 0100666 0000765 0000765 00000021461 05320470130 012105 0 ustar bulant bulant C SUBROUTINE 'RKGS' 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 RKGS C C PURPOSE C TO SOLVE A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS WITH GIVEN INITIAL VALUES. C C USAGE C CALL RKGS (PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C PARAMETERS FCT AND OUTP REQUIRE AN EXTERNAL STATEMENT. C C DESCRIPTION OF PARAMETERS C PRMT - AN INPUT AND OUTPUT VECTOR WITH DIMENSION GREATER C OR EQUAL TO 5, WHICH SPECIFIES THE PARAMETERS OF C THE INTERVAL AND OF ACCURACY AND WHICH SERVES FOR C COMMUNICATION BETWEEN OUTPUT SUBROUTINE (FURNISHED C BY THE USER) AND SUBROUTINE RKGS. EXCEPT PRMT(5) C THE COMPONENTS ARE NOT DESTROYED BY SUBROUTINE C RKGS AND THEY ARE C PRMT(1)- LOWER BOUND OF THE INTERVAL (INPUT), C PRMT(2)- UPPER BOUND OF THE INTERVAL (INPUT), C PRMT(3)- INITIAL INCREMENT OF THE INDEPENDENT VARIABLE C (INPUT), C PRMT(4)- UPPER ERROR BOUND (INPUT). IF ABSOLUTE ERROR IS C GREATER THAN PRMT(4), INCREMENT GETS HALVED. C IF INCREMENT IS LESS THAN PRMT(3) AND ABSOLUTE C ERROR LESS THAN PRMT(4)/50, INCREMENT GETS DOUBLED. C THE USER MAY CHANGE PRMT(4) BY MEANS OF HIS C OUTPUT SUBROUTINE. C PRMT(5)- NO INPUT PARAMETER. SUBROUTINE RKGS INITIALIZES C PRMT(5)=0. IF THE USER WANTS TO TERMINATE C SUBROUTINE RKGS AT ANY OUTPUT POINT, HE HAS TO C CHANGE PRMT(5) TO NON-ZERO BY MEANS OF SUBROUTINE C OUTP. FURTHER COMPONENTS OF VECTOR PRMT ARE C FEASIBLE IF ITS DIMENSION IS DEFINED GREATER C THAN 5. HOWEVER SUBROUTINE RKGS DOES NOT REQUIRE C AND CHANGE THEM. NEVERTHELESS THEY MAY BE USEFUL C FOR HANDING RESULT VALUES TO THE MAIN PROGRAM C (CALLING RKGS) WHICH ARE OBTAINED BY SPECIAL C MANIPULATIONS WITH OUTPUT DATA IN SUBROUTINE OUTP. C Y - INPUT VECTOR OF INITIAL VALUES. (DESTROYED) C LATERON Y IS THE RESULTING VECTOR OF DEPENDENT C VARIABLES COMPUTED AT INTERMEDIATE POINTS X. C DERY - INPUT VECTOR OF ERROR WEIGHTS. (DESTROYED) C THE SUM OF ITS COMPONENTS MUST BE EQUAL TO 1. C LATERON DERY IS THE VECTOR OF DERIVATIVES, WHICH C BELONG TO FUNCTION VALUES Y AT A POINT X. C NDIM - AN INPUT VALUE, WHICH SPECIFIES THE NUMBER OF C EQUATIONS IN THE SYSTEM. C IHLF - AN OUTPUT VALUE, WHICH SPECIFIES THE NUMBER OF C BISECTIONS OF THE INITIAL INCREMENT. IF IHLF GETS C GREATER THAN 10, SUBROUTINE RKGS RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. ERROR C MESSAGE IHLF=12 OR IHLF=13 APPEARS IN CASE C PRMT(3)=0 OR IN CASE SIGN(PRMT(3)).NE.SIGN(PRMT(2)- C PRMT(1)) RESPECTIVELY. C FCT - THE NAME OF AN EXTERNAL SUBROUTINE USED. THIS C SUBROUTINE COMPUTES THE RIGHT HAND SIDES DERY OF C THE SYSTEM TO GIVEN VALUES X AND Y. ITS PARAMETER C LIST MUST BE X,Y,DERY. SUBROUTINE FCT SHOULD C NOT DESTROY X AND Y. C OUTP - THE NAME OF AN EXTERNAL OUTPUT SUBROUTINE USED. C ITS PARAMETER LIST MUST BE X,Y,DERY,IHLF,NDIM,PRMT. C NONE OF THESE PARAMETERS (EXCEPT, IF NECESSARY, C PRMT(4),PRMT(5),...) SHOULD BE CHANGED BY C SUBROUTINE OUTP. IF PRMT(5) IS CHANGED TO NON-ZERO, C SUBROUTINE RKGS IS TERMINATED. C AUX - AN AUXILIARY STORAGE ARRAY WITH 8 ROWS AND NDIM C COLUMNS. C C REMARKS C THE PROCEDURE TERMINATES AND RETURNS TO CALLING PROGRAM, IF C (1) MORE THAN 10 BISECTIONS OF THE INITIAL INCREMENT ARE C NECESSARY TO GET SATISFACTORY ACCURACY (ERROR MESSAGE C IHLF=11), C (2) INITIAL INCREMENT IS EQUAL TO 0 OR HAS WRONG SIGN C (ERROR MESSAGES IHLF=12 OR IHLF=13), C (3) THE WHOLE INTEGRATION INTERVAL IS WORKED THROUGH, C (4) SUBROUTINE OUTP HAS CHANGED PRMT(5) TO NON-ZERO. C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C THE EXTERNAL SUBROUTINES FCT(X,Y,DERY) AND C OUTP(X,Y,DERY,IHLF,NDIM,PRMT) MUST BE FURNISHED BY THE USER. C C METHOD C EVALUATION IS DONE BY MEANS OF FOURTH ORDER RUNGE-KUTTA C FORMULAE IN THE MODIFICATION DUE TO GILL. ACCURACY IS C TESTED COMPARING THE RESULTS OF THE PROCEDURE WITH SINGLE C AND DOUBLE INCREMENT. C SUBROUTINE RKGS AUTOMATICALLY ADJUSTS THE INCREMENT DURING C THE WHOLE COMPUTATION BY HALVING OR DOUBLING. IF MORE THAN C 10 BISECTIONS OF THE INCREMENT ARE NECESSARY TO GET C SATISFACTORY ACCURACY, THE SUBROUTINE RETURNS WITH C ERROR MESSAGE IHLF=11 INTO MAIN PROGRAM. C TO GET FULL FLEXIBILITY IN OUTPUT, AN OUTPUT SUBROUTINE C MUST BE FURNISHED BY THE USER. C FOR REFERENCE, SEE C RALSTON/WILF, MATHEMATICAL METHODS FOR DIGITAL COMPUTERS, C WILEY, NEW YORK/LONDON, 1960, PP.110-120. C C .................................................................. C SUBROUTINE RKGS(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) C C DIMENSION Y(*),DERY(*),AUX(8,*),A(4),B(4),C(4),PRMT(*) DO 1 I=1,NDIM 1 AUX(8,I)=.06666667*DERY(I) X=PRMT(1) XEND=PRMT(2) H=PRMT(3) PRMT(5)=0. CALL FCT(X,Y,DERY) C C ERROR TEST IF(H*(XEND-X))38,37,2 C C PREPARATIONS FOR RUNGE-KUTTA METHOD 2 A(1)=.5 A(2)=.2928932 A(3)=1.707107 A(4)=.1666667 B(1)=2. B(2)=1. B(3)=1. B(4)=2. C(1)=.5 C(2)=.2928932 C(3)=1.707107 C(4)=.5 C C PREPARATIONS OF FIRST RUNGE-KUTTA STEP DO 3 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=0. 3 AUX(6,I)=0. IREC=0 H=H+H IHLF=-1 ISTEP=0 IEND=0 C C C START OF A RUNGE-KUTTA STEP 4 IF((X+H-XEND)*H)7,6,5 5 H=XEND-X 6 IEND=1 C C RECORDING OF INITIAL VALUES OF THIS STEP 7 CALL OUTP(X,Y,DERY,IREC,NDIM,PRMT) IF(PRMT(5))40,8,40 8 ITEST=0 9 ISTEP=ISTEP+1 C C C START OF INNERMOST RUNGE-KUTTA LOOP J=1 10 AJ=A(J) BJ=B(J) CJ=C(J) DO 11 I=1,NDIM R1=H*DERY(I) R2=AJ*(R1-BJ*AUX(6,I)) Y(I)=Y(I)+R2 R2=R2+R2+R2 11 AUX(6,I)=AUX(6,I)+R2-CJ*R1 IF(J-4)12,15,15 12 J=J+1 IF(J-3)13,14,13 13 X=X+.5*H 14 CALL FCT(X,Y,DERY) GOTO 10 C END OF INNERMOST RUNGE-KUTTA LOOP C C C TEST OF ACCURACY 15 IF(ITEST)16,16,20 C C IN CASE ITEST=0 THERE IS NO POSSIBILITY FOR TESTING OF ACCURACY 16 DO 17 I=1,NDIM 17 AUX(4,I)=Y(I) ITEST=1 ISTEP=ISTEP+ISTEP-2 18 IHLF=IHLF+1 X=X-H H=.5*H DO 19 I=1,NDIM Y(I)=AUX(1,I) DERY(I)=AUX(2,I) 19 AUX(6,I)=AUX(3,I) GOTO 9 C C IN CASE ITEST=1 TESTING OF ACCURACY IS POSSIBLE 20 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)21,23,21 21 CALL FCT(X,Y,DERY) DO 22 I=1,NDIM AUX(5,I)=Y(I) 22 AUX(7,I)=DERY(I) GOTO 9 C C COMPUTATION OF TEST VALUE DELT 23 DELT=0. DO 24 I=1,NDIM 24 DELT=DELT+AUX(8,I)*ABS(AUX(4,I)-Y(I)) IF(DELT-PRMT(4))28,28,25 C C ERROR IS TOO GREAT 25 IF(IHLF-10)26,36,36 26 DO 27 I=1,NDIM 27 AUX(4,I)=AUX(5,I) ISTEP=ISTEP+ISTEP-4 X=X-H IEND=0 GOTO 18 C C RESULT VALUES ARE GOOD 28 CALL FCT(X,Y,DERY) DO 29 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=AUX(6,I) Y(I)=AUX(5,I) 29 DERY(I)=AUX(7,I) CALL OUTP(X-H,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))40,30,40 30 DO 31 I=1,NDIM Y(I)=AUX(1,I) 31 DERY(I)=AUX(2,I) IREC=IHLF IF(IEND)32,32,39 C C INCREMENT GETS DOUBLED 32 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H IF(IHLF)4,33,33 33 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)4,34,4 34 IF(DELT-.02*PRMT(4))35,35,4 35 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H GOTO 4 C C C RETURNS TO CALLING PROGRAM 36 IHLF=11 CALL FCT(X,Y,DERY) GOTO 39 37 IHLF=12 GOTO 39 38 IHLF=13 39 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) 40 RETURN END C C======================================================================= C sec.for 0100666 0000765 0000765 00000207463 07071035074 011732 0 ustar bulant bulant CC Program SEC to determine the interfaces and velocity isolines in C 2-D sections of a 3-D seismic model. C C Date: 2000, March 31 C Coded by Ludek Klimes and Ivan Psencik 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 Geophysical Institute, Acad. Sci. Czech Rep., C Bocni II 1401, 141 31 Praha 4, Czech Republic, C E-mail: ip@ig.cas.cz C C The output interfaces and isolines may be written either in the form C of short lines (intersections of interfaces and isosurfaces with given C sections, stored by parts), or in the form of points (intersections C of interfaces and isosurfaces with given lines). 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 input and output files: C SECDAT='string' ... Name of the file containing input data for the C specification of the sections of the model. C Description of file SECDAT C Default: SECDAT='sec.dat' C MODEL='string'... Name of the input file with the data specifying C the model. C Description of MODEL C Example of MODEL C Default: MODEL='model.dat' C SECTS='string' ... Name of the output file with the generated C model sections. C Description of file SECTS C Default: SECTS='sec.out' C C C Input file SECDAT to specify the plotted section of the model: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new READ statement). C The variable names enclosed in apostrophes correspond to CHARACTER C strings. If the first letter of the symbolic name of the input C variable is I-N, the corresponding value in input data must be of C the type INTEGER. Otherwise, the input parameter is of the type C REAL. C (1) IPS,NC1,NC2,STEP,ERR C IPS... Positive to plot P-wave velocity isolines, C negative to plot S-wave velocity isolines. C NC1... Number of columns in each section. In Cartesian C coordinates each section has the shape of rhomboid. C In the normalized section coordinates, each section is a C square (0,1)*(0,1). Each section is divided into NC1 C columns of the same width, parallel with the second C normalized section coordinate axis. C NC2... Number of steps in the direction of the second normalized C section coordinate axis (i.e. along the columns), when C searching for the interfaces or isolines. C STEP... STEP.GT.0: the output interfaces and isolines are written C in the form of short lines (intersections of interfaces C and isosurfaces with given sections, stored by parts). C The file with lines has the name given by input C parameter 'SECTS' on the input line (1). C STEP... The relative step of the numerical integration C along interfaces and isolines. Measured in normalized C plot coordinates in which a section is represented by a C unit square (0,1)*(0,1). The initial points of the C isolines are determined along the axes of individual C columns (see NC1 above). Then the isolines are traced C by means of numerical integration. C STEP.EQ.0: no output file with the sections is generated. C Instead, the sections are roughly displayed on the C screen in a text mode. This option is not assumed to be C used. C STEP.LT.0: the output interfaces and isolines are written C in the form of points. The points are determined as the C points of intersection of interfaces and isosurfaces C with the given lines. The lines are defined as the axes C of individual columns (see NC1 above). C The file with points has the name given by input C parameter 'SECTS' on the input line (1). C STEP=-1 (strictly STEP.GT.-1.5): C File with points will contain only the coordinates of C points. C STEP=-2 (strictly STEP.LE.-1.5): C File with points will contain the coordinates of C points and the gradients of functions describing the C interface (the gradients are normal to the interface). C ERR... Maximum relative error in the direction of columns when C determining the positions of the interfaces or isolines C and, simultaneously, the upper error bound of the C numerical integration when tracing the isolines. Measured C in normalized plot coordinates in which a section is C represented by a unit square (0,1)*(0,1). C Default values: IPS=1, NC1=4, NC2=4, STEP=0.3/NC1, ERR=0.001. C (2) Values of isolines to be plotted terminated by a slash. C (3) Any times the following data (3.1): C (3.1) C10,C20,C30,C11,C21,C31,C12,C22,C32,C13,C23,C33,NREPET,/ C C10,C20,C30... Cartesian coordinates corresponding to the point of C plot coordinates (0,0) (i.e. to the origin of the plot C coordinates). If the model coordinates are curvilinear, C the mapping to the Cartesian coordinates is given by means C of the subroutine CARTES. C C11,C21,C31... Cartesian coordinates corresponding to the point of C plot coordinates (1,0) minus C10,C20,C30, respectively. C C12,C22,C32... Cartesian coordinates corresponding to the point of C plot coordinates (0,1) minus C10,C20,C30, respectively. C C13,C23,C33... Need not be specified for NREPET=0 (default). C For NREPET positive, C13,C23,C33 is the vectorial distance C between the origins of the two consecutive parallel C sections. C NREPET..If positive, NREPET additional sections, parallel with the C given section, will be generated. Origin (C10,C20,C30) of C each parallel section is origin (C10,C20,C30) of the C previous section plus (C13,C23,C33). C /... Obligatory slash at the end of line to facilitate future C extensions. C Default: NREPET=0. C (4) / (a slash) C for an example refer to the sample C input data set SECDAT C to generate P-wave velocity isolines in 21+11 vertical sections, C or input data set SECDAT C to discretize interfaces at the grid of 61*31 vertical lines. C C C Output file SECTS with lines (for step.GT.0): C (1) None to several strings terminated by / (a slash): C 'LINES SITUATED AT INTERFACES OR VELOCITY ISOSURFACES:' C 'character*78 string describing the model' C / C (2) V1,V2,...,VN,/ C List of isoline values terminated by a slash. C (3) For each model section (3.1), (3.2), and (3.3): C (3.1) C10,C20,C30,C11,C21,C31,C12,C22,C32 C Transformation matrix from normalized section coordinates C1,C2 to C the Cartesian coordinates X1,X2,X3: C X1=C10+C11*C1+C12*C2, C X2=C20+C21*C1+C22*C2, C X3=C30+C31*C1+C32*C2. C (3.2) For each isoline element (3.2.1), (3.2.2), and (3.2.3): C (3.2.1) LINE,IV C LINE... Positive: Index of the complex block. The isoline is a C velocity isoline. C Negative: Minus the index of a surface. The isoline is C a part of the structural interface. C IV... Index of the velocity value corresponding to the isoline C for NLINE positive, C 0 for NLINE negative. C (3.2.2) For each point of the element (3.2.2.1): C (3.2.2.1) C1,C2 C Normalized section coordinates of a point of the isoline. C (3.2.3) / (a slash). C (3.3) / (a slash). C (4) / (a slash) or end of file. C C Output file 'SECTS' with points (for STEP.LT.0): C (1) None to several strings terminated by / (a slash). C In fact, 2 strings and a slash are generated: C 'POINTS SITUATED AT INTERFACES OR VELOCITY ISOSURFACES:' C 'character*78 string describing the model' C / C (2) Written only for STEP.LE.-1.5: C D11,D21,D31,D12,D22,D32,D13,D23,D33 C Vectorial discretization steps: C D11=C11/NC1, D21=C21/NC1, D31=C31/NC1, C D12=C12/NC2, D22=C22/NC2, D32=C32/NC2, C D13=C13 , D23=C23 , D33=C33 . C (3) For each point of intersection of the vertical line (representing C the axis of the vertical column) the following line: C (3.1) 'SECTnnnnSURFisrf',X1,X2,X3,/ (for STEP.GT.-1.5) C 'SECTnnnnSURFisrf',X1,X2,X3,F1,F2,F3,/ (for STEP.LE.-1.5) C 'SECTnnnnSURFisrf'... Character*16 string composed of C substring 'SECT', index nnnn of the section, substring C 'SURF', and of index isrf of the surface covering the C structural interface at the point of intersection. C The indices are expressed in the format (I4). C String 'SECTnnnnSURFisrf' is enclosed in apostrophes. C X1,X2,X3... Cartesian coordinates of the point of intersection. C F1,F2,F3... Gradient of the function describing the surface at the C point of intersection. C (4) / (a slash) or end of file. In fact, a slash is generated. C C....................................................................... C C This file consists of the following external procedures: C SEC... Main program. It just invokes subroutine MODSEC. C SEC C FUNC... Subroutine designed to evaluate the value, first and C second derivatives of the given function with respect to C the plot coordinates. C FUNC C DISC... Subroutine designed to determine the point of intersection C of the given line segment with the boundary of the complex C block. It may also be used to determine the index of the C block in which the given point is situated. C DISC C ISOL... Subroutine designed to find the point of intersection C of the given line segment with an isoline. C ISOL C ISOLA...Auxiliary subroutine to the subroutine ISOL. C ISOLA C SECT1...Subroutine designed to read the input data for the C plotted section of the model and to store them in the C memory. C SECT1 C SECT2...Auxiliary subroutine to the subroutines DISC and ISOL. C The subroutine transforms the plot coordinates to the C model coordinates. C SECT2 C SECT3...Auxiliary subroutine to the subroutines DISC and ISOL. C The subroutine transforms the model coordinates to the C plot coordinates. C SECT3 C MODSEC..Subroutine demonstrating the function of the subroutines C DISC and ISOL (and, partially, also FUNC). It employs C the subroutines when sketching a section of the model by C means of extended ASCII characters onto the screen. The C subroutine is intended to be just an example how to use C the subroutines FUNC, DISC and ISOL of this file. C MODSEC C CONT1...Subroutine designed to initialize arrays containing the C points of intersection of isolines with vertical lines C limiting the regions of numerically tracing the isolines. C It is called once before tracing isolines in a new column C of the section. C CONT1 C CONT2...Subroutine designed to trace an isoline by means of C numerical integration within the given column. C CONT2 C FCTI... Subroutine evaluating the right-hand sides of the isoline C tracing equations. C FCTI C OUTI... Subroutine designed to check for the intersections of the C isoline with structural interfaces or boundaries of the C column in which the isoline is traced. C OUTI C C....................................................................... C C Storage in the memory: C The input data (2) to (4) are stored in common blocks /SECTC/ and C /VALUES/ defined in the include file 'sec.inc'. C sec.inc C C======================================================================= C C C PROGRAM SEC C CALL MODSEC STOP END C C To convert this program into subroutine package, enter the asterisks C to the first column of the four preceding FORTRAN statements. C C======================================================================= C C C SUBROUTINE FUNC(IFUNC,C,F) INTEGER IFUNC REAL C(2),F(3) C C This subroutine evaluates the value, first and second derivatives of C the given function with respect to the plot coordinates. C C Input: C IFUNC...Either: C Minus the index of the function describing a surface C covering a structural interface, or C -101, -102, -103, -104, -105 or -106 for the boundaries C of the model, or C The index of the complex block in which an isoline is C plotted. C C... Array of two plot coordinates of the given point. C C Output: C F... Array containing function value and the first partial C derivatives of the evaluated function in the order F, F1, C F2. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Common blocks /SECTC/ and /VALUES/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of the common blocks are altered. C C Subroutines and external functions required: EXTERNAL VELOC,CARTES,SRFC2,PARM2 C VELOC...File 'model.for'. C CARTES,KOOR... File 'metric.for'. C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C PARM2 and subsequent routines... File 'parm.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1992, November 2 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL AUX1,AUX2,AUX3 REAL COOR(3),CART(3),PDER(9) REAL UP(10),US(10),QP,QS,VD(10) C C....................................................................... C C Cartesian coordinates CART(1)=C10+C11*C(1)+C12*C(2) CART(2)=C20+C21*C(1)+C22*C(2) CART(3)=C30+C31*C(1)+C32*C(2) C C Model coordinates CALL CARTES(COOR,.FALSE.,CART,PDER) C C Evaluating the function in the model coordinates IF(IFUNC.GT.0) THEN CALL PARM2(IFUNC,COOR,UP,US,AUX3,QP,QS) CALL VELOC(IPS,UP,US,QP,QS,AUX1,AUX2,VD,AUX3) ELSE IF(IFUNC.GE.-100) THEN CALL SRFC2(-IFUNC,COOR,VD) ELSE I=(-IFUNC-99)/2 VD(1)=COOR(I)-BOUNDM(-IFUNC-100) VD(2)=0. VD(3)=0. VD(4)=0. VD(I+1)=1. END IF C C Gradient in Cartesian coordinates AUX1=PDER(1)*VD(2)+PDER(2)*VD(3)+PDER(3)*VD(4) AUX2=PDER(4)*VD(2)+PDER(5)*VD(3)+PDER(6)*VD(4) AUX3=PDER(7)*VD(2)+PDER(8)*VD(3)+PDER(9)*VD(4) C C Gradient in plot coordinates F(1)=VD(1) F(2)=C11*AUX1+C21*AUX2+C31*AUX3 F(3)=C12*AUX1+C22*AUX2+C32*AUX3 RETURN END C C======================================================================= C C C SUBROUTINE DISC(X1,C1,DC1,X2,C2,DC2,ERR,C1MIN,C1MAX,C2MIN,C2MAX, * LINE,ISB1,ICB1,ISRF,ISB2,ICB2) REAL X1,C1(2),DC1(2),X2,C2(2),DC2(2),ERR,C1MIN,C1MAX,C2MIN,C2MAX INTEGER LINE,ISB1,ICB1,ISRF,ISB2,ICB2 C C This subroutine determines the point of intersection of the given line C segment with the boundary of the complex block. It may also be used C to determine the index of the block in which the given point is C situated. C C Input: C X1... Independent variable corresponding to the first given C point. C C1... Array of plot coordinates corresponding to the first given C point. C DC1... Array containing the derivatives of plot coordinates with C respect to the independent variable at the first given C point. C X2... Independent variable corresponding to the second given C point. C C2... Array of plot coordinates corresponding to the second C given point. C DC2... Array containing the derivatives of plot coordinates with C respect to the independent variable at the second given C point. C ERR... Maximum error in independent variable for the C determination of the point of intersection. C C1MIN,C1MAX,C2MIN,C2MAX... Boundaries of the region in which the C line should be situated. C LINE... If the line is a surface, index of the surface. C In this case, input value of ISB1 and ICB1 may C correspond to a material block on its either side. C If the line is situated inside a block, LINE=0. C ISB1,ICB1... Index of the simple block and index of the complex C block in which the point C1 is situated, ICB1=0 if the C indices are yet unknown. C C Output: C X2,C2,DC2... Independent variable, array of plot coordinates and C array containing their derivatives, corresponding to the C endpoint of the line element. If both two given points of C the line are situated in the same complex block, the C endpoint of the line element coincides with the second C given point. Otherwise, the endpoint is the point of C intersection of the line with the boundary of the complex C block. C ISB1,ICB1... Index of the simple block and index of the complex C block in which the end of line (at C2) is situated. C ISB1=0 and ICB1=0 if the point C1 is situated in a free C space. ISB1=0 and ICB1=0 for the point C1 being situated C outside the computational volume, too. C Note: if the point C1 is situated in a free space or C outside the computational volume (output ICB1=0), C indices ISRF, ISB2 and ICB2 are not defined. C ISRF... Index of the surface at which the endpoint of the line C element is situated, supplemented by a sign '+' or '-' for C the endpoint situated at the positive or negative side of C the surface, respectively. C Zero inside the complex block. C ISRF=201 or 202 if crossing the given boundaries C1MIN or C C1MAX, respectively. C ISB2,ICB2... Indices of the simple block and index of the complex C block at point C2 from the other side than the line. C If the point C2 is situated at the boundary of the complex C block ICB1 (i.e. for ISRF.NE.0), ISB2,ICB2 are the C indices of the simple block and index of the complex C block, touching the complex block ICB1 from the other side C of the surface ISRF at the endpoint of the line element. C ISB2=0 and ICB2=0 for a free space on the other side of C isrf. ISB2=0 and ICB2=0 for the surface ISRF being the C boundary of the computational volume. C C Common block /MODELC/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: INTEGER NSRFC EXTERNAL BLOCK,SRFC2,CDE,NSRFC,SECT2,SECT3 C NSRFC,BLOCK... File 'model.for'. C CARTES... File 'metric.for'. C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C CDE,CROSS,HIVD2... File 'means.for'. C SECT2,SECT3... This file. C C Date: 1999, March 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I,IY(8) REAL FAUX(10),CBOUND(1) REAL Y1(3),D1(3),Y2(3),D2(3),XA,YA(3),DA(3),XB,YB(3),DB(3) C C....................................................................... C C Determination of the complex block in which the first point lies CALL SECT2(C1,DC1,Y1,D1) IF(ICB1.EQ.0) THEN C Check for crossing the end surfaces * DO 11 I=1,NEND * CALL SRFC2(IABS(KEND(I)),Y1,FAUX) * IF(FAUX(1)*FLOAT(KEND(I)).LE.0.) THEN * GO TO 90 * END IF * 11 CONTINUE C Check for crossing the coordinate boundaries of the C computational volume: DO 12 I=1,3 IF(Y1(I).LT.BOUNDM(I+I-1)) THEN GO TO 90 END IF IF(Y1(I).GT.BOUNDM(I+I)) THEN GO TO 90 END IF 12 CONTINUE C Searching for the complex block in which the first point lies: CALL BLOCK(Y1,0,0,ISRF,ISB1,ICB1) IF(ICB1.EQ.0) THEN GO TO 90 END IF END IF C C Intersection of the given line segment with the boundaries C1MIN, C C1MAX of the region in which the line should be situated ISRF=0 20 CONTINUE IF(ISRF.NE.201.AND.C1MIN.GT.C2(1)) THEN I=1 ISRF=201 FAUX(1)=C1MIN ELSE IF(ISRF.NE.202.AND.C2(1).GT.C1MAX) THEN I=1 ISRF=202 FAUX(1)=C1MAX ELSE IF(ISRF.NE.203.AND.C2MIN.GT.C2(2)) THEN I=2 ISRF=203 FAUX(1)=C2MIN ELSE IF(ISRF.NE.204.AND.C2(2).GT.C2MAX) THEN I=2 ISRF=204 FAUX(1)=C2MAX ELSE GO TO 30 END IF XA=X2 YA(1)=C2(1) YA(2)=C2(2) DA(1)=DC2(1) DA(2)=DC2(2) CALL CROSS(SECT2,101,I,I,2,ERR,X1,C1,DC1,X2,C2,DC2,XA,YA,DA, * XB,YB,DB,FAUX) C Here SECT2 just fills the place reserved for external procedure. X2=XA C2(1)=YA(1) C2(2)=YA(2) DC2(1)=DA(1) DC2(2)=DA(2) GO TO 20 C C Intersection of the given line segment with the boundary of the C complex block 30 CONTINUE CALL SECT2(C2,DC2,Y2,D2) XA=X2 DO 31 I=1,3 YA(I)=Y2(I) DA(I)=D2(I) 31 CONTINUE IY(4)=ISB1 IY(5)=ICB1 IY(6)=ISRF CALL CDE(IABS(LINE),0,I,0,I,CBOUND, * 1,3,3,IY,ERR,X1,X1,Y1,D1,X2,Y2,D2,XA,YA,DA,XB,YB,DB) IF(IY(6).EQ.ISRF) THEN ISB2=IY(4) ICB2=IY(5) ELSE IF(IABS(IY(6)).LE.NSRFC()) THEN ISB2=IY(7) ICB2=IY(8) ELSE ISB2=0 ICB2=0 END IF ISB1=IY(4) ISRF=IY(6) X2=XB CALL SECT3(YB,DB,C2,DC2) RETURN C 90 CONTINUE ISB1=0 ISRF=0 ISB2=0 ICB2=0 RETURN END C C======================================================================= C C C SUBROUTINE ISOL(X1,C1,DC1,X2,C2,DC2,ERR,ICB1) REAL X1,C1(2),DC1(2),X2,C2(2),DC2(2),ERR INTEGER ICB1 C C This subroutine finds the point of intersection of the given line C segment with an isoline. C C Input: C X1... Independent variable corresponding to the first given C point. C C1... Array of plot coordinates corresponding to the first given C point. C DC1... Array containing the derivatives of plot coordinates with C respect to the independent variable at the first given C point. C X2... Independent variable corresponding to the second given C point. C C2... Array of plot coordinates corresponding to the second C given point. C DC2... Array containing the derivatives of plot coordinates with C respect to the independent variable at the second given C point. C ERR... Maximum error in independent variable for the C determination of the point of intersection. C ICB1... Index of the complex block in which the points C1 and C2 C are situated. C C Output: C X1,C1,DC1... Independent variable, array of plot coordinates and C array containing their derivatives, corresponding to the C point of intersection of the line with the isoline closest C to the first given point. C C Common block /VALUES/: INCLUDE 'sec.inc' C sec.inc C Input: C IPS,VALUE,NV... Given values, see the description in the include C file 'sec.inc'. C IV... If the input values of X1,C1,DC1 are the output ones from C the last invocation of this subroutine, IV should be C unchanged since that invocation. C If the interval X1,C1,DC1 to X2,C2,DC2 has been changed C since the last invocation of this subroutine, IV has to C be set to zero. C Output: C IV... Index in the array value of the isoline closest to the C first given point. C Zero, if there is no isoline in the given interval. C None of the storage locations of the common block, except IV, are C altered. C C Subroutines and external functions required: EXTERNAL CROSS,FUNC,ISOLA,SECT2,SECT3 C VELOC... File 'model.for'. C CARTES,KOOR... File 'metric.for'. C SRFC2 and subsequent routines... File 'srfc.for' and subsequent C files (like 'val.for' and 'fit.for'). C PARM2 and subsequent routines... File 'parm.for' and subsequent C files (like 'val.for' and 'fit.for'). C CROSS,HIVD2... File 'means.for'. C FUNC,ISOLA,SECT2,SECT3... This file. C C Date: 1992, November 2 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I REAL F1(3),F2(10) REAL Y1(3),D1(3),Y2(3),D2(3),XA,YA(3),DA(3),XB,YB(3),DB(3) C C....................................................................... C CALL FUNC(ICB1,C1,F1) CALL FUNC(ICB1,C2,F2) IF(F1(1).LT.F2(1)) THEN IF(IV.EQ.0) THEN DO 11 IV=1,NV IF(VALUE(IV).GT.F1(1)) THEN GO TO 12 END IF 11 CONTINUE IV=NV+1 12 CONTINUE ELSE IV=IV+1 END IF IF(IV.GT.NV) THEN IV=0 ELSE IF(VALUE(IV).GT.F2(1)) THEN IV=0 END IF ELSE IF(IV.EQ.0) THEN DO 13 IV=NV,1,-1 IF(VALUE(IV).LT.F1(1)) THEN GO TO 14 END IF 13 CONTINUE IV=0 14 CONTINUE ELSE IV=IV-1 END IF IF(IV.GT.0) THEN IF(VALUE(IV).LT.F2(1)) THEN IV=0 END IF END IF END IF C IF(IV.GT.0) THEN C there is an isoline no. Iv in the given interval CALL SECT2(C1,DC1,Y1,D1) CALL SECT2(C2,DC2,Y2,D2) XA=X2 DO 21 I=1,3 YA(I)=Y2(I) DA(I)=D2(I) 21 CONTINUE CALL ISOLA(ICB1,YA,F2) CALL CROSS(ISOLA,ICB1,1,3,3,ERR,X1,Y1,D1,X2,Y2,D2,XA,YA,DA, * XB,YB,DB,F2) X1=XB CALL SECT3(YA,DA,C1,DC1) END IF C RETURN END C C======================================================================= C C C SUBROUTINE ISOLA(ICB1,COOR,F) INTEGER ICB1 REAL COOR(3),F(10) C C Auxiliary subroutine to the subroutine ISOL. C This subroutine evaluates the value, first and second derivatives of C the given function with respect to the model coordinates. It is C intended to be called by the subroutine cross of the file 'means.for' C in order to find the point of intersection of the given line segment C with an isoline. Note that the isoline is the zero isoline of the C function evaluated by this subroutine. C C Input: C ICB1... Index of the complex block in which the points C1 and C2 C are situated. C COOR... Array of three model coordinates of the given point. C C Output: C F... Array containing function value, the first and second C partial derivatives of the evaluated function in the C order F, F1, F2, F3, F11, F12, F22, F13, F23, F33. C C Common block /VALUES/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: C EXTERNAL VELOC,PARM2 C VELOC... File 'model.for'. C PARM2 and subsequent routines... File 'parm.for' and subsequent C files (like 'val.for' and 'fit.for'). C C Date: 1991, June 25 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: REAL AUX1,AUX2,AUX3 REAL UP(10),US(10),QP,QS C C....................................................................... C C Evaluating the function in the model coordinates CALL PARM2(ICB1,COOR,UP,US,AUX3,QP,QS) CALL VELOC(IPS,UP,US,QP,QS,AUX1,AUX2,F,AUX3) F(1)=F(1)-VALUE(IV) RETURN END C C======================================================================= C C C SUBROUTINE SECT1(LU1,LU2,ISECT,NC1,NC2,STEP,ERR) INTEGER LU1,LU2,ISECT,NC1,NC2 REAL STEP,ERR C C This subroutine reads the data for the plotted section of the model. C C Input: C LU1... Logical number of the external unit connected to the file C with the main input data. C If zero, main input data are read from the * external C interactive device. C LU2... Logical unit number of the external output device to store C the lines or points situated at structural interfaces or C velocity isosurfaces. C This logical unit is used for reading the input data, C then connected to the output file opened in this routine. C Note that the output file is not opened if STEP=0 in the C input data file. C ISECT...for the first invocation ISECT=0, C otherwise the unchanged output from the previous C invocation. C C Output: C ISECT...ISECT=0 if there remains no model section to compute. C Then the output parameters NC1,NC2,STEP,ERR are C unchanged input. C Otherwise the input value increased by one. C Then the output parameters NC1,NC2,STEP,ERR are read C from the input data file. C NC1... Number of vertical columns in the print of the model C section. C NC2... Number of steps in the vertical direction when looking for C the interfaces or isolines. C STEP... Relative step of the numerical integration along C interfaces and isolines. C ERR... Relative error in the vertical direction when determining C the positions of the interfaces or isolines and, C simultaneously, the upper error bound of the numerical C integration. C C Common block /MODELT/: INCLUDE 'model.inc' C model.inc C None of the storage locations of the common block are altered. C C Common blocks /SECTC/ and /VALUES/: INCLUDE 'sec.inc' C sec.inc C The storage locations of the common blocks are defined in this C subroutine. C C Subroutines and external functions required: EXTERNAL MODEL1 C MODEL1 and subsequent routines... File 'model.for' and subsequent C files (like 'metric.for', 'srfc.for', 'parm.for', C 'val.for', and 'fit.for'). C C Date: 1996, September 30 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Automatic generation of parallel sections: INTEGER NREPET REAL C13,C23,C33 SAVE C13,C23,C33,NREPET C NREPET..Number of sections parallel with the given section. C C13,C23,C33... Offset of the origins of the consecutive parallel C sections. C C Auxiliary storage locations: CHARACTER*80 MODEL,SECTS REAL D11,D21,D31,D12,D22,D32 REAL AUX1,AUX2,AUX3,AUX4,AUX5,AUX6,AUX7,AUX8,AUX9 C C....................................................................... C IF(ISECT.EQ.0) THEN C C (1) Opening data files and reading the input data: CALL RSEP3T('MODEL',MODEL,'model.dat') CALL RSEP3T('SECTS',SECTS,'sec.out') OPEN(LU2,FILE=MODEL,STATUS='OLD') CALL MODEL1(LU2) CLOSE(LU2) C C (2) IPS=1 NC1=4 NC2=4 STEP=0.3/FLOAT(NC1) ERR=0.001 IF(LU1.EQ.0) THEN READ(*,*) IPS,NC1,NC2,STEP,ERR ELSE READ(LU1,*) IPS,NC1,NC2,STEP,ERR END IF C C (3) DO 11 NV=1,MV VALUE(NV)=0. 11 CONTINUE IF(LU1.EQ.0) THEN READ(*,*) VALUE ELSE READ(LU1,*) VALUE END IF DO 12 NV=1,MV IF(VALUE(NV).EQ.0.) THEN GO TO 13 END IF 12 CONTINUE NV=MV+1 13 CONTINUE NV=NV-1 IV=0 C C Output file: IF(STEP.NE.0.) THEN OPEN(LU2,FILE=SECTS) IF(STEP.GT.0.) THEN WRITE(LU2,'(3A)') * '''LINES SITUATED AT INTERFACES OR VELOCITY ISOSURFACES:''' ELSE WRITE(LU2,'(3A)') * '''POINTS SITUATED AT INTERFACES OR VELOCITY ISOSURFACES:''' END IF WRITE(LU2,'(3A)') '''',TEXTM(1:78),'''' WRITE(LU2,'(A)') '/' IF(STEP.GT.0.) THEN C Terminal line of file, overwritten using backspace in the C case of output WRITE(LU2,'(A)') '/' END IF END IF C C Initialization: NREPET=0 C END IF C ISECT=ISECT+1 IF(NREPET.LE.0) THEN C C (4) AUX1=C10 AUX2=C20 AUX3=C30 AUX4=C11 AUX5=C21 AUX6=C31 AUX7=C12 AUX8=C22 AUX9=C32 IF(LU1.EQ.0) THEN READ(*,*) C10,C20,C30,C11,C21,C31,C12,C22,C32,C13,C23,C33, * NREPET ELSE READ(LU1,*) C10,C20,C30,C11,C21,C31,C12,C22,C32,C13,C23,C33, * NREPET END IF IF(AUX1.EQ.C10.AND.AUX4.EQ.C11.AND.AUX7.EQ.C12.AND. * AUX2.EQ.C20.AND.AUX5.EQ.C21.AND.AUX8.EQ.C22.AND. * AUX3.EQ.C30.AND.AUX6.EQ.C31.AND.AUX9.EQ.C32) THEN C End of computation ISECT=0 ELSE IF(STEP.LE.-1.5) THEN IF(NREPET.LT.0) THEN C SEC-01 CALL ERROR('SEC-01: NREPET negative') END IF D11=C11/FLOAT(NC1) D21=C21/FLOAT(NC1) D31=C31/FLOAT(NC1) D12=C12/FLOAT(NC2) D22=C22/FLOAT(NC2) D32=C32/FLOAT(NC2) WRITE(LU2,'( 9(F10.6,1X) )') * D11,D21,D31,D12,D22,D32,C13,C23,C33 END IF END IF C ELSE C C Parallel section with the previous one: C10=C10+C13 C20=C20+C23 C30=C30+C33 NREPET=NREPET-1 C END IF RETURN END C C======================================================================= C C C SUBROUTINE SECT2(C,DC,COOR,DCOOR) REAL C(2),DC(2),COOR(3),DCOOR(3) C C Auxiliary subroutine to the subroutines DISC and ISOL. C This subroutine transforms the plot coordinates to the model C coordinates. C C Input: C C... Array of two plot coordinates of the given point. C C Output: C COOR... Array containing the model coordinates X1, X2, X3 of the C given point. C C Common block /SECTC/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL CARTES C CARTES,KOOR... File 'metric.for'. C C Date: 1991, October 7 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: REAL CART(3),PDER(9),AUX1,AUX2,AUX3 C C....................................................................... C C Cartesian coordinates: CART(1)=C10+C11*C(1)+C12*C(2) CART(2)=C20+C21*C(1)+C22*C(2) CART(3)=C30+C31*C(1)+C32*C(2) AUX1=C11*DC(1)+C12*DC(2) AUX2=C21*DC(1)+C22*DC(2) AUX3=C31*DC(1)+C32*DC(2) C C Model coordinates: CALL CARTES(COOR,.FALSE.,CART,PDER) DCOOR(1)=PDER(1)*AUX1+PDER(4)*AUX2+PDER(7)*AUX3 DCOOR(2)=PDER(2)*AUX1+PDER(5)*AUX2+PDER(8)*AUX3 DCOOR(3)=PDER(3)*AUX1+PDER(6)*AUX2+PDER(9)*AUX3 C RETURN END C C======================================================================= C C C SUBROUTINE SECT3(COOR,DCOOR,C,DC) REAL COOR(3),DCOOR(3),C(2),DC(2) C C Auxiliary subroutine to the subroutines DISC and ISOL. C This subroutine transforms the model coordinates to the plot C coordinates. C C Input: C COOR... Array containing the model coordinates X1, X2, X3 of the C given point. C C Output: C C... Array of two plot coordinates of the given point. C C Common block /SECTC/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL CARTES C CARTES,KOOR... File 'metric.for'. C C Date: 1991, October 7 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: REAL CART(3),AUX1,AUX2 REAL B11,B12,B22,BDET,DAUX1,DAUX2,DAUX3,PDER(9) C C....................................................................... C C Cartesian coordinates: CALL CARTES(COOR,.TRUE.,CART,PDER) DAUX1=PDER(1)*DCOOR(1)+PDER(4)*DCOOR(2)+PDER(7)*DCOOR(3) DAUX2=PDER(2)*DCOOR(1)+PDER(5)*DCOOR(2)+PDER(8)*DCOOR(3) DAUX3=PDER(3)*DCOOR(1)+PDER(6)*DCOOR(2)+PDER(9)*DCOOR(3) C C Plot coordinates: B11=C11*C11+C21*C21+C31*C31 B12=C11*C12+C21*C22+C31*C32 B22=C12*C12+C22*C22+C32*C32 BDET=B11*B22-B12*B12 AUX1=(CART(1)-C10)*C11+(CART(2)-C20)*C21+(CART(3)-C30)*C31 AUX2=(CART(1)-C10)*C12+(CART(2)-C20)*C22+(CART(3)-C30)*C32 C(1)=( B22*AUX1-B12*AUX2)/BDET C(2)=(-B12*AUX1+B11*AUX2)/BDET AUX1=DAUX1*C11+DAUX2*C21+DAUX3*C31 AUX2=DAUX1*C12+DAUX2*C22+DAUX3*C32 DC(1)=( B22*AUX1-B12*AUX2)/BDET DC(2)=(-B12*AUX1+B11*AUX2)/BDET C RETURN END C C======================================================================= C C C SUBROUTINE MODSEC C C Subroutine demonstrating the function of the subroutines DISC and ISOL C (and, partially, also FUNC). It employs the subroutines when C sketching a section of the model by means of extended ASCII C characters onto the screen. This subroutine is intended to be just an C example how to use the subroutines FUNC, DISC and ISOL of this file. C C No argument input nor output. C C Common block /VALUES/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of the common block, except IV, are C altered. C C Subroutines and external functions required: INTEGER NSRFC EXTERNAL NSRFC,DISC,ISOL,SECT1,CONT1,CONT2 C C Date: 1995, March 31 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C CHARACTER*80 FILSEP INTEGER LU0 PARAMETER (LU0=1) C CHARACTER*80 FILE INTEGER LU1,LU2,ISECT,NC1,NC2 REAL STEP,ERR C C FILE... Name of the main input data file. C LU1... Logical unit number of the input data file. C LU2... Logical unit number of the output file with generated C model sections. C ISECT...Sequential number of the currently evaluated model C section. C NC1... Number of vertical columns in the model section. C NC2... 1/NC2 is the relative step in the vertical direction when C looking for the interfaces or isolines. C STEP... Step of the numerical integration when computing the C interfaces or isolines. C ERR... Relative error in the vertical direction when determining C the positions of the interfaces or isolines. C INTEGER MSRFC PARAMETER (MSRFC=100) INTEGER KVALUE(MV),KSRFC(MSRFC) INTEGER ISB1,ICB1,ISRF,ISB2,ICB2,ISB0,ICB0,I REAL X1,C1(2),DC1(2),X2,C2(2),DC2(2),C0,DIRECT REAL COOR(3),DCOOR(3),VD(10) C C KVALUE(I)... The last column intersected by the I-th isoline. C KSRFC(I)... The last column intersected by the I-th surface. C ISB1,ICB1... Index of the simple block and index of the complex C block in which the point C1 is situated. C ISRF... Index of the surface at which the endpoint of the line C element is situated, supplemented by a sign '+' or '-' for C the endpoint situated at the positive or negative side of C the surface, respectively. C Zero inside the complex block. C ISB2,ICB2... Index of the simple block and index of the complex C block, touching the complex block icb1 from the other side C of the surface ISRF at the endpoint of the line element. C ISB2=0 and ICB2=0 for a free space on the other side of C ISRF. C Undefined inside the complex block, defined only at the C point of intersection of the line with the boundary of the C complex block. C ISB0,ICB0... Last values of ISB1,ICB1 corresponding to DIRECT=+1, C when DIRECT=-1. C I... Auxiliary loop variable. C X1,X2...Independent variables along the lines, in this case C coinciding with C1(2) and C2(2), respectively. C C1,C2...Vectors of the relative position within the model section. C DC1,DC2... Derivatives of the arrays C1,C2 with respect to the C independent variable. C C0... C DIRECT..Direction in which we are searching for the interfaces or C isolines, takes the values +1 or -1. C VD... Temporary storage to evaluate normal to the interface. C INTEGER IFUNC,IBACK INTEGER MC1,MC2,IC1,IC2 PARAMETER(MC1=75,MC2=20) CHARACTER*(MC1) PICT(MC2) C C IFUNC...Either: C Minus the index of the function describing a surface C covering a structural interface, or C -101, -102, -103, -104, -105 or -106 for the boundaries C of the model, or C the index of the complex block in which an isoline is C plotted. C IBACK...Loop variable. C MC1... Maximum number of vertical columns in the print of the C model section. C MC2... Number of horizontal rows in the print of the model C section. C IC1,IC2...Indices. C PICT...Character array containing the print of the model. C C....................................................................... C LU1=11 LU2=12 C C Reading name of SEP file with input data: WRITE(*,'(A)') '+SEC: Enter input filename: ' FILSEP=' ' READ(*,*) FILSEP WRITE(*,'(A)') '+SEC: Working ... ' C C Reading all data from the SEP file into the memory: IF (FILSEP.NE.' ') THEN CALL RSEP1(LU0,FILSEP) ELSE C SEC-04 CALL ERROR('SEC-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('SECDAT',FILE,'sec.dat') C C Opening main input data file: IF(LU1.NE.0) THEN OPEN(LU1,FILE=FILE,STATUS='OLD') WRITE(*,'(A)') '+ ' END IF C C Loop for sections of the model ISECT=0 10 CONTINUE C C Reading the input data CALL SECT1(LU1,LU2,ISECT,NC1,NC2,STEP,ERR) IF(ISECT.EQ.0) THEN C .............................................................. C End of calculation IF(STEP.NE.0.) THEN IF(STEP.NE.0.) THEN IF(STEP.GT.0.) THEN BACKSPACE(LU2) END IF WRITE(LU2,'(A)') '/' END IF CLOSE(LU2) END IF WRITE(*,'(A)') '+SEC: Done. ' C .............................................................. RETURN END IF C DC1(1)=0. DC2(1)=0. C ................................................................ C Starting with a new section: IF(STEP.EQ.0.) THEN IF(NC1.GT.MC1) THEN C SEC-02 CALL ERROR('SEC-02: Character array PICT too small') END IF DO 11 IC2=1,MC2 PICT(IC2)=' ' 11 CONTINUE IF(ISECT.GT.1) THEN WRITE(*,'(A)') ' ' END IF ELSE DO 16 I=1,MIN0(NSRFC(),MSRFC) KSRFC(I)=-1 16 CONTINUE DO 17 I=1,NV KVALUE(I)=-1 17 CONTINUE END IF C ................................................................ WRITE(*,'(9(A,I4,5X))') '+Section',ISECT C C Loop for the vertical lines (columns in the print of the model) DO 80 IC1=1,NC1 DIRECT=1. C1(1)=(FLOAT(IC1)-.5)/FLOAT(NC1) C2(1)=C1(1) C1(2)=0. ISB1=0 ICB1=0 C .............................................................. C New column: IF(STEP.GT.0.) THEN CALL CONT1(IC1,NC1) END IF C .............................................................. C Loop for the intervals of the size 1/NC2 along a vertical line C when looking for the interfaces or isolines 20 CONTINUE C2(2)=AMIN1(C1(2)+DIRECT/FLOAT(NC2),1.) DC1(2)=DIRECT DC2(2)=DIRECT X1=DIRECT*C1(2) X2=DIRECT*C2(2) *** IC2=INT(FLOAT(NC2)*(C1(2)+C2(2))/2.+1.) *** WRITE(*,'(9(A,I4,5X))') *** * '+Section',ISECT,'Column',IC1,'Elevation',IC2 *-* WRITE(*,'(9(A,I4,5X))') *-* * '+SECTION',ISECT,'COLUMN',IC1 CALL DISC(X1,C1,DC1,X2,C2,DC2,ERR,0.,1.,0.,1., * 0,ISB1,ICB1,ISRF,ISB2,ICB2) IF(ICB1.EQ.0) THEN C Point C1 is situated within a free space ICB0=0 C1(2)=C1(2)+1./FLOAT(NC2) DIRECT=-1. ELSE C Point C1 is situated within a material complex block IF(ICB0.EQ.0) THEN ISB0=ISB1 ICB0=ICB1 C0=C1(2) END IF IV=0 30 CONTINUE CALL ISOL(X1,C1,DC1,X2,C2,DC2,ERR,ICB1) IF(IV.NE.0) THEN C Point of intersection of the vertical line with an C isoline C ........................................................ IF(STEP.EQ.0.) THEN IC2= * MAX0(0,MIN0(MC2,INT((1.-C1(2)+ERR/2.)*FLOAT(MC2)+1.))) IF(PICT(IC2)(IC1:IC1).EQ.' ') THEN C plotting isoline IF(C1(2).GT.1.-(FLOAT(IC2)-.67)/FLOAT(MC2)) THEN PICT(IC2)(IC1:IC1)='~' ELSE IF(C1(2).GT.1.-(FLOAT(IC2)-.33)/FLOAT(MC2))THEN PICT(IC2)(IC1:IC1)='-' ELSE PICT(IC2)(IC1:IC1)='_' END IF END IF ELSE CALL SECT2(C1,DC1,COOR,DCOOR) IF(STEP.LT.0.) THEN IBACK=1 ELSE IBACK=2 END IF DO 31 IBACK=1,IBACK IF(STEP.GT.0.) THEN BACKSPACE(LU2) END IF IF(KVALUE(IV).LT.IC1-1.OR.STEP.LT.0.) THEN C Writing the reference coordinates: IF(IPS.GT.0) THEN WRITE(LU2,'(3(A,I4),A,F6.3,A,3(G12.6,X),A)') * '''SECT',ISECT,', BLOC',ICB1,', ISOL',IV, * ', VP =', * VALUE(IV),'''',COOR(1),COOR(2),COOR(3),' /' ELSE WRITE(LU2,'(3(A,I4),A,F6.3,A,3(G12.6,X),A)') * '''SECT',ISECT,', BLOC',ICB1,', ISOL',IV, * ', VS =', * VALUE(IV),'''',COOR(1),COOR(2),COOR(3),' /' END IF ELSE C Writing / in place of reference coordinates: IF(IPS.GT.0) THEN WRITE(LU2,'(3(A,I4),A,F6.3,A)') * '''SECT',ISECT,', BLOC',ICB1,', ISOL',IV, * ', VP =',VALUE(IV),''' /' ELSE WRITE(LU2,'(3(A,I4),A,F6.3,A)') * '''SECT',ISECT,', BLOC',ICB1,', ISOL',IV, * ', VS =',VALUE(IV),''' /' END IF END IF KVALUE(IV)=IC1 IF (STEP.GT.0.) THEN IFUNC=ICB1 CALL CONT2(LU2,IFUNC,IBACK,ISB1,ICB1,0,0,STEP,ERR, * C1) END IF 31 CONTINUE END IF C ........................................................ GO TO 30 END IF IF(ISRF.NE.0.AND.IABS(ISRF).LE.100) THEN C Crossing an interface C ........................................................ IF(STEP.EQ.0.) THEN IC2=MAX0(0,MIN0(MC2,INT((1.-C2(2))*FLOAT(MC2)+1.))) IF(C2(2).GT.1.-(FLOAT(IC2)-.5)/FLOAT(MC2)) THEN PICT(IC2)(IC1:IC1)=CHAR(223) ELSE PICT(IC2)(IC1:IC1)=CHAR(220) END IF ELSE CALL SECT2(C2,DC2,COOR,DCOOR) IF(STEP.LT.0.) THEN IBACK=1 ELSE IBACK=2 END IF DO 36 IBACK=1,IBACK IF(STEP.GT.0.) THEN BACKSPACE(LU2) END IF IFUNC=IABS(ISRF) IF(KSRFC(MIN0(IFUNC,MSRFC)).LT.IC1-1.OR.STEP.LT.0.) * THEN C writing the reference coordinates: IF(STEP.GT.-1.5) THEN WRITE(LU2,'(2(A,I4),A,3(G12.6,X),A)') * '''SECT',ISECT,', SURF',IFUNC,'''', * COOR(1),COOR(2),COOR(3),' /' ELSE CALL SRFC2(IFUNC,COOR,VD) *** WRITE(LU2,'(2(A,I4),A,6(G12.6,X),A)') *** * '''SECT',ISECT,', SURF',IFUNC,'''', WRITE(LU2,'( A,6(G12.6,X),A)') * ''' ''', * COOR(1),COOR(2),COOR(3),VD(2),VD(3),VD(4),' /' END IF ELSE C Writing / in place of reference coordinates: WRITE(LU2,'(2(A,I4),A)') * '''SECT',ISECT,', SURF',IFUNC,''' /' END IF IF(IFUNC.LT.MSRFC) THEN KSRFC(IFUNC)=IC1 END IF IF(STEP.GT.0.) THEN IFUNC=-IFUNC C IFUNC=101,...,106 for the computational volume C boundary. CALL CONT2(LU2,IFUNC,IBACK,ISB1,ICB1,ISB2,ICB2, * STEP,ERR,C2) END IF 36 CONTINUE END IF C ........................................................ IF(ICB2.EQ.0) THEN C Crossing free surface IF(DIRECT.LT.0.) THEN ISB2=ISB0 ICB2=ICB0 C2(2)=C0 ELSE C2(2)=C1(2)+1./FLOAT(NC2) END IF DIRECT=-DIRECT END IF END IF ISB1=ISB2 ICB1=ICB2 C1(2)=C2(2) END IF IF(C1(2).LT.0.) THEN C SEC-03 CALL ERROR * ('SEC-03: Negative plot coordinate - contact the author') END IF IF(C1(2).LT.1.-ERR) GO TO 20 80 CONTINUE C C ................................................................ C Section finished: IF(STEP.EQ.0.) THEN WRITE(*,'(1X,999A1)') CHAR(218),(CHAR(196),I=1,NC1),CHAR(191) DO 90 IC2=1,MC2 WRITE(*,'(1X,A1,A,A1)') CHAR(179),PICT(IC2)(1:NC1),CHAR(179) 90 CONTINUE WRITE(*,'(1X,999A1)') CHAR(192),(CHAR(196),I=1,NC1),CHAR(217) END IF C ................................................................ C GO TO 10 C End of loop for sections of the model C WRITE(*,'(A)') '+SEC: Done. ' END C C======================================================================= C C C SUBROUTINE CONT1(IC1,NC1) INTEGER IC1,NC1 C C Subroutine designed to initialize arrays containing the points of C intersection of isolines with vertical lines limiting the regions of C numerically tracing the isolines. It is called once before tracing C isolines in a new column of the section. C C Input: C IC1... Index of the given column in the model section. C NC1... Number of columns in the model section. C C No output. C C Common block /COLUMN/: INCLUDE 'sec.inc' C sec.inc C C Date: 1994, January 26 C Coded by Ivan Psencik, and Ludek Klimes C C----------------------------------------------------------------------- C INTEGER I C C....................................................................... C COLL=AMAX1((FLOAT(IC1)-1.5)/FLOAT(NC1),0.) COLM= (FLOAT(IC1)-0.5)/FLOAT(NC1) COLR=AMIN1((FLOAT(IC1)+0.5)/FLOAT(NC1),1.) IF(IC1.EQ.1) THEN INTL=0 ELSE INTL=INTR DO 1 I=1,INTL ZL(I)=ZR(I) 1 CONTINUE END IF INTM=0 INTR=0 RETURN END C C======================================================================= C C C SUBROUTINE CONT2(LU2,IFUNC,IBACK,ISB1,ICB1,ISB2,ICB2,STEP,ERR,YP) INTEGER LU2,IFUNC,IBACK,ISB1,ICB1,ISB2,ICB2 REAL STEP,ERR,YP(2) C C Subroutine designed to trace an isoline by means of numerical C integration, within the given column. C C Input: C LU2... Logical unit number of the output file with generated C isolines. C STEP... Step of the numerical integration when computing the C interfaces or isolines. C ERR... Upper error bound of points of the isoline determined by C means of numerical integration. C IFUNC...Either: C Minus the index of the function describing a surface C covering a structural interface, or C -101, -102, -103, -104, -105 or -106 for the boundaries C of the model, or C the index of the complex block in which an isoline is C plotted. C IBACK...1 or 2, index of the direction in which the isoline is to C be followed. C ISB1,ICB1... Index of the simple block and index of the complex C block in which the initial point YP of the isoline is C situated. C ISB2,ICB2... Index of the simple block and index of the complex C block, touching the complex block icb1 from the other side C of the surface ISRF=-IFUNC at the initial point YP. C Need not be defined for a velocity isoline (IFUNC C positive). C STEP... Step of the numerical integration when computing the C interfaces or isolines. C ERR... Upper error bound of points of the isoline determined by C means of numerical integration. C YP... Array containing two normalized section coordinates of the C initial point of the isoline to be calculated. C C No output. C C Common blocks /VALUES/ and /CONTC/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of common block /VALUES/ are altered. C C Subroutines and external functions required: EXTERNAL RKGS * EXTERNAL HPCG EXTERNAL FCTI,OUTI C C Date: 1994, January 26 C Coded by Ivan Psencik, and Ludek Klimes C C----------------------------------------------------------------------- C INTEGER IHLF,I REAL YPOC(2),DERY(2),AUX(16,2),PRMT(6) C C....................................................................... C IFUN=IFUNC PRMT(1)=0. PRMT(2)=999999. PRMT(3)=STEP PRMT(4)=ERR PRMT(6)=FLOAT(LU2)+.5 C NBACK=IBACK ISB1O=ISB1 ICB1O=ICB1 ISB2O=ISB2 ICB2O=ICB2 NBOD=0 YPOC(1)=YP(1) YPOC(2)=YP(2) C For RKGS: DERY(1)=.5 DERY(2)=.5 CALL RKGS(PRMT,YPOC,DERY,2,IHLF,FCTI,OUTI,AUX) C For HPCG (PRMT(4)=13.444*ERR): * DERY(1)=.03719 * DERY(2)=.03719 * CALL HPCG(PRMT,YPOC,DERY,2,IHLF,FCTI,OUTI,AUX) C C Writing data describing isolines into the file LU2 IF(NBOD.GT.1)THEN IF(PRMT(5).GT.-100..AND.PRMT(5).LT.100.) THEN C Isoline terminates at an interface C I=INT(SIGN(ABS(PRMT(5))+.5,PRMT(5))) I=INT( ABS(PRMT(5)) ) WRITE(LU2,'(A,I3,A)') '/ (TERMINATING AT SURFACE',I,')' ELSE WRITE(LU2,'(A)') '/' END IF C Terminal line of file, overwritten using backspace in the case C of output WRITE(LU2,'(A)') '/' END IF C RETURN END C C======================================================================= C C C SUBROUTINE FCTI(X,Y,DERY) REAL X,Y(*),DERY(*) C C Subroutine evaluating the right-hand sides of the isoline tracing C equations. C C Input: C X... Value of the independent variable along the isoline. C Y... Array containing two normalized section coordinates of a C point of the isoline, determined by means of numerical C integration. C C Output: C Y... Array containing two normalized section coordinates of the C of the isoline, corrected by means of the linearization in C the direction of the gradient (perpendicular to the C isoline). C DERY... Array containing derivatives of the normalized coordinates C Y with respect to X. C C Common blocks /VALUES/ and /CONTC/: INCLUDE 'sec.inc' C sec.inc C None of the storage locations of common /VALUES/ block are altered. C C Date: 1994, January 26 C Coded by Ivan Psencik, and Ludek Klimes C C----------------------------------------------------------------------- C REAL S(3),S1,S2,AUX C C....................................................................... C CALL FUNC(IFUN,Y,S) S1=S(2) S2=S(3) AUX=SQRT(S1*S1+S2*S2) DERY(1)=S2/AUX DERY(2)=-S1/AUX IF (NBACK.EQ.2) THEN DERY(1)=-DERY(1) DERY(2)=-DERY(2) END IF C C Correction of the isoline IF(IFUN.GT.0) THEN AUX=(S(1)-VALUE(IV))/AUX/AUX ELSE AUX=S(1)/AUX/AUX END IF Y(1)=Y(1)-S1*AUX Y(2)=Y(2)-S2*AUX C RETURN END C C======================================================================= C C C SUBROUTINE OUTI(X,Y,DERY,IHLF,NDIM,PRMT) INTEGER IHLF,NDIM REAL X,Y(NDIM),DERY(NDIM),PRMT(*) C C Subroutine designed to check for the intersections of the isoline with C structural interfaces or boundaries of the column in which the isoline C is traced. C C Input: C X... Value of the independent variable along the isoline. C Y... Array containing two normalized section coordinates of a C point of the isoline. C DERY... Array containing derivatives of the normalized coordinates C Y with respect to X. C IHLF... Number of bisections of the initial increment of the C independent variable. C NDIM... Number of ordinary differential equations. C PRMT... Array containing parameters of the integration. C PRMT(6) contains the logical unit number of the output C file with generated isolines, increased by 0.5. C C Output: C X,Y,DERY... Values corresponding to the point of intersection of C the isoline with the boundary of the complex block or the C computational region (column of the section), if the C isoline intersects the boundary. Unaltered if the isoline C does not intersect the boundary (i.e. if PRMT(5) remains C unchanged). C PRMT(5)=301,302... The isoline has already been determined and C will not be traced again. C 201,202,203,204... The isoline has intersected the C boundary of the computational region (column of the C section). C ISRF... Index of the intersected surface limiting the C complex block if a structural interface has been C crossed. C Otherwise unaltered. C C Common blocks /COLUMN/ and /CONTC/: INCLUDE 'sec.inc' C sec.inc C C Date: 1994, January 26 C Coded by Ivan Psencik, and Ludek Klimes C C----------------------------------------------------------------------- C LOGICAL LEFT INTEGER LINE,ISB1,ICB1,ISRF,ISRFO,I,LU2 REAL ERR,ERROR,BNDL,BNDR REAL XOLD,YOLD(2),DOLD(2) REAL COOR(3),DCOOR(3) SAVE LEFT,BNDL,BNDR,XOLD,YOLD,DOLD C C....................................................................... C ERR=PRMT(4) ERROR=PRMT(4) * ERROR=10.*PRMT(4) C IF(NBOD.EQ.0) THEN IF(DERY(1).LT.0.) THEN C The next point of an isoline or a discontinuity will be C situated to the left from the first point. The first point is C tested whether an isoline or a discontinuity has been C constructed through it LEFT=.TRUE. BNDL=COLL BNDR=COLM DO 6 I=1,INTL IF(ABS(ZL(I)-Y(2)).LT.ERROR) THEN PRMT(5)=301. RETURN END IF 6 CONTINUE ELSE C The next point of an isoline or a discontinuity will be C situated to the right from the first point. The first point is C tested whether an isoline or a discontinuity has been C constructed through it LEFT=.FALSE. BNDL=COLM BNDR=COLR DO 7 I=1,INTM IF(ABS(ZM(I)-Y(2)).LT.ERROR) THEN PRMT(5)=302. RETURN END IF 7 CONTINUE END IF ELSE C C Check for crossing the boundary of the complex block ISB1=ISB1O ICB1=ICB1O IF(IFUN.GE.0) THEN LINE=0 ELSE LINE=-IFUN END IF CALL DISC(XOLD,YOLD,DOLD,X,Y,DERY,ERR,BNDL,BNDR,0.,1., * LINE,ISB1,ICB1,ISRF,ISB1O,ICB1O) IF(LINE.NE.0)THEN ISRFO=ISRF ISB1=ISB2O ICB1=ICB2O CALL DISC(XOLD,YOLD,DOLD,X,Y,DERY,ERR,BNDL,BNDR,0.,1., * LINE,ISB1,ICB1,ISRF,ISB2O,ICB2O) IF(ISRF.EQ.0) THEN ISRF=ISRFO END IF END IF C C Test whether the isoline or discontinuity intersects middle C vertical grid line COLM: IF(LEFT)THEN IF(ISRF.EQ.202)THEN C storing the point of intersection of the isoline or C interface with the middle vertical grid line INTL=INTL+1 ZL(INTL)=Y(2) END IF ELSE IF(ISRF.EQ.201)THEN C Storing the point of intersection of the isoline or C interface with the middle vertical grid line INTM=INTM+1 ZM(INTM)=Y(2) END IF C C Test whether the isoline or discontinuity intersects right C vertical grid line COLR: IF(ISRF.EQ.202)THEN C Storing the point of intersection of the isoline or C interface with the right vertical grid line INTR=INTR+1 ZR(INTR)=Y(2) END IF END IF C C End of checks for crossing boundaries PRMT(5)=FLOAT(ISRF) END IF C XOLD=X YOLD(1)=Y(1) YOLD(2)=Y(2) DOLD(1)=DERY(1) DOLD(2)=DERY(2) C NBOD=NBOD+1 CALL SECT2(Y,DERY,COOR,DCOOR) LU2=INT(PRMT(6)) WRITE(LU2,'(3(G12.6,X),A)') COOR(1),COOR(2),COOR(3),' /' IF(NBOD.GT.1000)THEN C SEC-51 CALL WARN('SEC-51: More then 1000 points of the isoline') 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 'model.for' C model.for INCLUDE 'metric.for' C metric.for INCLUDE 'srfc.for' C srfc.for INCLUDE 'parm.for' C parm.for INCLUDE 'val.for' C val.for INCLUDE 'fit.for' C fit.for INCLUDE 'means.for' C means.for INCLUDE 'rkgs.for' C rkgs.for C C======================================================================= Csec.inc 0100666 0000765 0000765 00000010276 06355637664 011730 0 ustar bulant bulant CC INCLUDE 'sec.inc' C ------------------------------------------------------------------ REAL C10,C20,C30,C11,C21,C31,C12,C22,C32 COMMON/SECTC/ C10,C20,C30,C11,C21,C31,C12,C22,C32 SAVE /SECTC/ C .................................................................. INTEGER IPS,MV,NV,IV PARAMETER (MV=128) REAL VALUE(MV) COMMON/VALUES/ IPS,VALUE,NV,IV SAVE /VALUES/ C .................................................................. REAL ZL(100),ZM(100),ZR(100),COLL,COLM,COLR INTEGER INTL,INTM,INTR COMMON/COLUMN/ZL,ZM,ZR,COLL,COLM,COLR,INTL,INTM,INTR SAVE /COLUMN/ C .................................................................. INTEGER IFUN,NBACK,ISB1O,ICB1O,ISB2O,ICB2O,NBOD COMMON/CONTC/ IFUN,NBACK,ISB1O,ICB1O,ISB2O,ICB2O,NBOD C ------------------------------------------------------------------ C C10,C20,C30,C11,C21,C31,C12,C22,C32... Input data (2). C C IPS... Input data (3). C VALUE...Input data (4). C NV... Number of non-zero isoline values in the input data (4). C IV... Index in the array value of the isoline currently being C plotted. C Zero, if there is no isoline in the given interval. C Output of the subroutine ISOL. If the interval where an C isoline is looked for has been changed since the last C invocation of the subroutine ISOL, IV has to be set to C zero. C C ZL,ZM,ZR... The second normalized section coordinates of the C points of intersection of the isolines with lines COLL, C COLM, and COLR, respectively. C COLL... The first normalized section coordinate of the left-hand C boundary line of the left-hand region for isoline tracing. C COLM... The first normalized section coordinate of the middle C boundary line between the two regions for isoline tracing. C The initial point of the isoline is assumed to be situated C at this line. C COLR... The first normalized section coordinate of the right-hand C boundary line of the right-hand region for isoline C tracing. C INTL,INTM,INTR... Numbers of the points of intersection of the C isolines with lines COLL, COLM, and COLR, respectively. C C IFUN... Either: C Minus the index of the function describing a surface C covering a structural interface, or C -101, -102, -103, -104, -105 or -106 for the boundaries C of the model, or C The index of the complex block in which an isoline is C plotted. C NBACK...1 or 2, index of the direction in which the isoline is to C be followed. C ISB1O,ICB1O... Index of the simple block and index of the complex C block in which the initial point of the isoline is C situated. C ISB2O,ICB2O... Index of the simple block and index of the complex C block, touching the complex block ICB1O from the other C side of the surface ISRF=-IFUN at the initial point. C Need not be defined for a velocity isoline (IFUN C positive). C NBOD... Number of points along the calculated part of the isoline C (the part situated within the given column of the C section). C C Common block /SECTC/ is included in external procedures FUNC, C SECT1, SECT2 and SECT3. C Common block /VALUES/ is included in external procedures FUNC, C ISOL, ISOLA, SECT1 and MODSEC. C The index of the last allocated numeric storage unit of array C VALUE is named MV and is given by the sixth and seventh statement C of the block data subroutine SECTB. If the value of MV is C changed, it must be adjusted in all subroutines which include the C common block /VALUES/. C C The common blocks are included in FORTRAN 77 source code file C 'sec.for'. C C Date: 1996, July 8 C Coded by Ludek Klimes C C======================================================================= Csob11.dat 0100666 0000765 0000765 00000000125 07022375312 012047 0 ustar bulant bulant 1 0 0 0 1 0 0 0 1 / Norm (L2-norm of gradient) 1. 0. 1. 0. 0. 1. sob22.dat 0100666 0000765 0000765 00000000302 07115122734 012047 0 ustar bulant bulant 2 0 0 0 2 0 0 0 2 0 1 1 1 0 1 1 1 0 / Isotropic 1 .333333 1 .333333 .333333 1 0 0 0 1.333333 0 0 0 0 1.333333 0 0 0 0 0 1.333333 sob22l.dat 0100666 0000765 0000765 00000000304 07021403076 012222 0 ustar bulant bulant 2 0 0 0 2 0 0 0 2 0 1 1 1 0 1 1 1 0 / Squared Laplace (lambda) 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 sob22n.dat 0100666 0000765 0000765 00000000266 07021403146 012231 0 ustar bulant bulant 2 0 0 0 2 0 0 0 2 0 1 1 1 0 1 1 1 0 / Norm (2mu) 1 0 1 0 0 1 0 0 0 2 0 0 0 0 2 0 0 0 0 0 2 sob33.dat 0100666 0000765 0000765 00000000675 07115122740 012063 0 ustar bulant bulant 3 0 0 1 2 0 1 0 2 0 3 0 2 1 0 0 1 2 0 0 3 2 0 1 0 2 1 1 1 1 / Isotropic 1.0 0.6 1.8 0.6 0.6 1.8 0 0 0 1.0 0 0 0 0.6 1.8 0 0 0 0.6 0.6 1.8 0 0 0 0 0 0 1.0 0 0 0 0 0 0 0.6 1.8 0 0 0 0 0 0 0.6 0.6 1.8 0 0 0 0 0 0 0 0 0 2.4 sob33l.dat 0100666 0000765 0000765 00000000676 07021403076 012240 0 ustar bulant bulant 3 0 0 1 2 0 1 0 2 0 3 0 2 1 0 0 1 2 0 0 3 2 0 1 0 2 1 1 1 1 / Gradient of Laplace 1 1 1 1 1 1 0 0 0 1 0 0 0 1 1 0 0 0 1 1 1 0 0 0 0 0 0 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 sob33n.dat 0100666 0000765 0000765 00000000657 07021403146 012237 0 ustar bulant bulant 3 0 0 1 2 0 1 0 2 0 3 0 2 1 0 0 1 2 0 0 3 2 0 1 0 2 1 1 1 1 / Norm 1 0 3 0 0 3 0 0 0 1 0 0 0 0 3 0 0 0 0 0 3 0 0 0 0 0 0 1 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 6 soft.for 0100666 0000765 0000765 00000027262 07135511410 012122 0 ustar bulant bulant CSUBROUTINE SOFT * (ICLASS,NA1,NA2,NA3,NB1,NB2,NB3,NW,WEIGHT,NM,INDM,CS,MB,B) C INTEGER ICLASS,NA1,NA2,NA3,NB1,NB2,NB3,NW,NM,INDM(*),MB REAL WEIGHT(NW,ICLASS),CS(*),B(MB) C C This subroutine accumulates the prior subjective information C covariance matrix describing the smoothness of the functions C interpolated by means of subroutines of the file 'val.for'. C C Input: C ICLASS..Index of the class required. C NA1,NA2,NA3... Orders of X1,X2,X3-partial derivatives of the first C basis function in the product being integrated. C NB1,NB2,NB3... Orders of X1,X2,X3-partial derivatives of the C second basis function in the product being integrated. C If triplets (NA1,NA2,NA3) and (NB1,NB2,NB3) are C different, both Sobolev scalar products corresponding to C derivatives (NA1,NA2,NA3),(NB1,NB2,NB3) and C (NA1,NA2,NA3),(NB1,NB2,NB3) are added to matrix CS. C NW... Maximum index that identifies the physical meaning of the C function. C NM... Input number of the unknown model parameters. C Zero for the first required class, output from the C previous invocation for subsequent classes of functions. C WEIGHT..Weighting factors corresponding to the derivatives. C WEIGHT(MPAR,ICLASS) is the weighting factor corresponding C to the function indexed MPAR of the ICLASSth class. C CS... Symmetric matrix to be regularized: C Contribution corresponding to the derivatives will be C added to the corresponding part of matrix CS if some of C WEIGHT(MPAR,ICLASS).NE.0. C Not used if WEIGHT(*,*)=0. C MB... Dimension of working array B. C B... Working array. Auxiliary storage locations for partial C covariance matrices. For the comments on its minimum C dimension refer to the destription of error C 372. Not used if WEIGHT=0. C C Output: C NM... Output number of the unknown model parameters. C INDM... Indices of the unknown model parameters. Integer array of C dimension NM. C CS... Resulting symmetric subjective prior information C covariance matrix (input matrix increased by WEIGHT times C the product of the derivatives averaged over the B-spline C grid). If triplets (NA1,NA2,NA3) and (NB1,NB2,NB3) are C different, both Sobolev scalar products corresponding to C derivatives (NA1,NA2,NA3),(NB1,NB2,NB3) and C (NA1,NA2,NA3),(NB1,NB2,NB3) are added. C CS is stored as a real array of dimension NM*(NM+1)/2. C Unchanged input if WEIGHT(*,*)=0. C C Common block: INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: EXTERNAL SPSP C C Date: 2000, July 20 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C INTEGER JGROUP,LFUNCT,MFUNCT,JFUNCT,LADR,MADR,IADR,NVAR INTEGER NA(3),NB(3),NX(3),NX1,NX2,NX3 EQUIVALENCE (NX(1),NX1),(NX(2),NX2),(NX(3),NX3) INTEGER JADR(7),JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7 EQUIVALENCE (JADR(1),JADR1),(JADR(2),JADR2),(JADR(3),JADR3) EQUIVALENCE (JADR(4),JADR4),(JADR(5),JADR5),(JADR(6),JADR6) EQUIVALENCE (JADR(7),JADR7) INTEGER I1,I2,I3,II,I,J,N,MPAR REAL WDENS,SIGMA C C B... Auxiliary storage locations for partial covariance C matrices. C ICLASS..Index of the class. C JGROUP..Address of a current group. C LFUNCT,MFUNCT,JFUNCT... Addresses of the first, last and arbitrary C functions of the group. C LADR,MADR,IADR... Addresses of the first, last and arbitrary C parameters of the current function. C NVAR... Number of the independent variables A1, A2, A3 of the C interpolated function W. C NX=(NX1,NX2,NX3)... Numbers of grid lines. C JADR=(JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7)... Addresses of C parameters describing the interpolated function (grid C coordinates, B-spline coefficients, B-spline basis C functions). C I1,I2,I3,I,J,N,MPAR... Local auxiliary variables. C WDENS...Weighting factor divided by volume (area,length). C SIGMA...Tension factor. C C....................................................................... C C NM=0 C IF(NCLASS.LT.1.OR.IPAR(0).LT.NCLASS) THEN IF(ICLASS.LT.1.OR.IPAR(0).LT.ICLASS) THEN C 371 CALL ERROR('371 in SOFT: Incorrect number of classes') C The number of classes required is zero, negative or greater than C the number of classes defined. END IF C Loop for classes: C DO 92 ICLASS=1,NCLASS C Loop for groups of the current class: DO 91 JGROUP=IPAR(ICLASS-1)+1,IPAR(ICLASS) LFUNCT=IPAR(JGROUP-1)+1 MFUNCT=IPAR(JGROUP) MADR =IPAR(LFUNCT-1) C C Loop for functions of the current group: DO 90 JFUNCT=LFUNCT,MFUNCT C Starting and end addresses of the parameters describing the C function LADR=MADR+1 MADR=IPAR(JFUNCT) IF(LADR.LE.MADR) THEN MPAR=IPAR(LADR) IF(MPAR.LT.1.OR.MPAR.GT.NW) THEN C 373 CALL ERROR('373 in SOFT: Incorrect index of function') C The index that identifies the physical meaning of the C function is not in range 1 to MPAR. Check the C invocations of subroutine VAL1 and of this subroutine. END IF WDENS=WEIGHT(MPAR,ICLASS) C Tension factor SIGMA=RPAR(LADR+5) C C The number, types and values of the independent variables C of the interpolated function: C Initial address IADR=LADR+6 C Initial number of the independent variables NVAR=0 NA(1)=0 NA(2)=0 NA(3)=0 NB(1)=0 NB(2)=0 NB(3)=0 NX1=1 NX2=1 NX3=1 JADR1=0 JADR2=0 JADR3=0 JADR4=0 C Loop for the possible independent variables: DO 20 I=LADR+2,LADR+4 C Type of the possible independent variable: J=IPAR(I) IF(J.GT.0) THEN N=IABS(IPAR(IADR)) IF(N.GE.2) THEN NVAR=NVAR+1 IF(J.EQ.1) THEN NA(NVAR)=NA1 NB(NVAR)=NB1 ELSE IF(J.EQ.2) THEN NA(NVAR)=NA2 NB(NVAR)=NB2 ELSE IF(J.EQ.3) THEN NA(NVAR)=NA3 NB(NVAR)=NB3 END IF NX(NVAR)=N ELSE IF(N.EQ.1) THEN JADR(NVAR+1)=JADR(NVAR+1)+1 END IF IADR=IADR+1 END IF 20 CONTINUE JADR5=0 JADR6=0 JADR7=0 C C Interpolated function W: JADR1=IADR+JADR1 IF(NVAR.LE.0) THEN C No independent variable. JADR4=JADR1 ELSE JADR2=JADR1+NX1+JADR2 WDENS=WDENS/(RPAR(JADR1+NX1-1)-RPAR(JADR1)) IF(NVAR.EQ.1) THEN C One independent variable: JADR4=JADR2 JADR5=JADR4+NX1 ELSE JADR3=JADR2+NX2+JADR3 WDENS=WDENS/(RPAR(JADR2+NX2-1)-RPAR(JADR2)) IF(NVAR.EQ.2) THEN C Two independent variables: JADR4=JADR3 JADR5=JADR4+NX1*NX2 JADR6=JADR5+5*NX1 ELSE C Three independent variables: JADR4=JADR3+NX3+JADR4 JADR5=JADR4+NX1*NX2*NX3 JADR6=JADR5+5*NX1 JADR7=JADR6+5*NX2 WDENS=WDENS/(RPAR(JADR3+NX3-1)-RPAR(JADR3)) END IF END IF END IF C WDENS is weighting factor divided by volume (area,length). C JADR4=JADR4-1 N=NX1*NX2*NX3 I=NA1+NA2+NA3-NA(1)-NA(2)-NA(3) * +NB1+NB2+NB3-NB(1)-NB(2)-NB(3) IF(WDENS.EQ.0..OR.I.NE.0) THEN DO 72 I2=1,N INDM(NM+I2)=JADR4+I2 72 CONTINUE NM=NM+N ELSE IF(NA1.EQ.NB1.AND.NA2.EQ.NB2.AND.NA3.EQ.NB3) THEN I=N*(N+1)/2 J=0 ELSE I=N*N J=1 END IF IF(NA(1).EQ.NB(1)) THEN I1=NX1*(NX1+1)/2 ELSE I1=NX1*NX1 END IF IF(NA(2).EQ.NB(2)) THEN I2=NX2*(NX2+1)/2 ELSE I2=NX2*NX2 END IF IF(NA(3).EQ.NB(3)) THEN I3=NX3*(NX3+1)/2 ELSE I3=NX3*NX3 END IF I1=I1+I I2=I2+I1 I3=I3+I2 IF(I3.GT.MB) THEN C 372 CALL ERROR('372 in SOFT: Insufficient working memory') C The dimension MB of the buffer B is not sufficient. C See the above command lines, where NX1,NX2,NX3 are C the dimensions of the grid for spline interpolation C of a single function describing a surface or a C material parameter. Dimension MB must be sufficiently C large for each interpolated function. C MB and B(MB) are the dummy arguments of this C subroutine. If the actual argument is allocated in C array RAM(MRAM) declared in include file C ram.inc, C you may wish to increase MRAM. END IF DO 80 II=1,I B(II)=0. 80 CONTINUE CALL SPSP(NA(1),NA(2),NA(3),NB(1),NB(2),NB(3), * NX1,NX2,NX3, * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3), * RPAR(JADR5),RPAR(JADR6),RPAR(JADR7), * SIGMA,WDENS,B(1),B(I+1),B(I1+1),B(I2+1)) I=NM*(NM+1)/2 DO 82 I2=1,N INDM(NM+I2)=JADR4+I2 I=I+NM DO 81 I1=1,I2 I=I+1 IF(J.EQ.0) THEN CS(I)=CS(I)+B(I2*(I2-1)/2+I1) ELSE CS(I)=CS(I)+B(N*(I2-1)+I1)+B(N*(I1-1)+I2) END IF 81 CONTINUE 82 CONTINUE NM=NM+N C Contribution corresponding to the derivatives C is added to the matrix CS. END IF C END IF 90 CONTINUE 91 CONTINUE C 92 CONTINUE C End of loops for functions. C RETURN END C C======================================================================= Cspsp.for 0100666 0000765 0000765 00000061274 06367275524 012160 0 ustar bulant bulant CSUBROUTINE SPSP(NAX,NAY,NAZ,NBX,NBY,NBZ,NX,NY,NZ, * X,Y,Z,VX,VY,VZ,SIGMA,WEIGHT,B,BX,BY,BZ) C INTEGER NAX,NAY,NAZ,NBX,NBY,NBZ,NX,NY,NZ REAL X(NX),Y(NY),Z(NZ),VX(5,NX),VY(5,NY),VZ(5,NZ) REAL SIGMA,WEIGHT,B(*),BX(*),BY(*),BZ(*) C C Complement to FITPACK C by Alan Kaylor Cline C coded -- January 23, 1994 C by Ludek Klimes C Department of Geophysics C Charles University, Prague C C This subroutine evaluates the Sobolev scalar products C of spline under tension basis functions in three variables C (the Sobolev scalar product consists of integrals of the C products of partial derivatives of the two argument functions) C C On input-- C C NXA, NYA, NZA are the orders of partial derivatives of C the first argument function in the scalar product C C NXB, NYB, NZB are the orders of partial derivatives of C the second argument function in the scalar product C C NX, NY, NZ are the numbers of grid points in the C X-, Y-, Z-directions, respectively. (NX, NY, NZ C should be at least 1) C C X, Y, and Z are arrays of the NX, NY, and NZ coordinates C of the grid lines in the X-, Y-, and Z-directions, C respectively. These should be strictly increasing. C C VX, VY,VZ are arrays of lengths 5*NX, 5*NY, 5*NZ, C respectively, containing the B-spline basis data for the C X-, Y- and Z-grids. They contain certain coefficients C to be used for the determination of the B-spline under C tension basis. Considered as a 5 by N array, for I = 1, C ... , N, B-spline basis function I is specified by-- C V(1,I) = second derivative at X(I-1), for I .NE. 1, C V(2,I) = second derivative at X(I), for all I, C V(3,I) = second derivative at X(I+1), for I .NE. N, C V(4,I) = function value at X(I-1), for I .NE. 1, C V(5,I) = function value at X(I+1), for I .NE. N, C and the properties that it has-- C 1. Function value 1 at X(I), C 2. Function value and second derivative = 0 at C X(1), ... , X(I-2), and X(I+2), ... , X(N). C In V(5,N) and V(3,N) are contained function value and C second derivative of basis function zero at X(1), C respectively. In V(4,1) and V(1,1) are contained C function value and second derivative of basis function C N+1 at X(N), respectively. Function value and second C derivative of these two basis functions are zero at all C other knots. Only basis function zero has non-zero C second derivative value at X(1) and only basis C function N+1 has non-zero second derivative at X(N). C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the basis functions are approximately cubic C splines. If ABS(SIGMA) is large (e. g. 50.) the basis C functions are nearly piecewise linear. If SIGMA equals C zero a cubic spline basis results. A standard value for C SIGMA is approximately 1. In absolute value. C C WEIGHT is the weight of the product of NXA,NYA,NZA-partial C derivative of the first argument and NXB,NYB,NZB-partial C derivative of the second argument, in the Sobolev scalar C product. The integral of the product of the partial C derivatives multiplied by WEIGHT is added to matrix B. C C B is the array containing NN*NN matrix B (NN=NX*NY*NZ), C stored as a symmetric matrix ( NN*(NN+1)/2 storage C locations ) if NAX.EQ.NBX and NAY.EQ.NBY and NAZ.EQ.NBZ, C else stored as a general matrix ( NN*NN storage C locations ). The II,JJ-element of the matrix B C will be increased by the integral of the product of C NXA-,NYA-,NZA-partial derivative of the II-th basis C function and NXB-,NYB-,NZB-partial derivative of the C JJ-th basis function, multiplied by WEIGHT. C Here the basis function IX,IY,IZ (1.LE.IX.LE.NX, C 1.LE.IY.LE.NY, 1.LE.IZ.LE.NZ) is indexed by C II=IX+NX*(IY+NY*IZ). C C BX is an auxiliary array of at least NX*(NX+1)/2 C locations for NXA.EQ.NXB, or of at least NX*NX locations C for NXA.NE.NXB. It is used for scratch storage. C C BY is an auxiliary array of at least NY*(NY+1)/2 C locations for NYA.EQ.NYB, or of at least NY*NY locations C for NYA.NE.NYB. It is used for scratch storage. C C BZ is an auxiliary array of at least NZ*(NZ+1)/2 C locations for NZA.EQ.NZB, or of at least NZ*NZ locations C for NZA.NE.NZB. It is used for scratch storage. C C And C C None of the input parameters, except B, BX, BY, BZ, are C altered C C The parameters NX, NY, NZ, X, Y, Z, VX, VY, VZ and SIGMA C should be input unaltered from the output of VAL3B1 C (SURFB1, CURVB1). C C On output-- C C B is the input array increased by the integrals of the C products of NXA-,NYA-,NZA-partial derivatives and C NXB-,NYB-,NZB-partial derivatives of the spline under C tension basis functions, multiplied by WEIGHT. C C This subroutine references package modules QSPL, QINT, C and SNHCSH. C EXTERNAL QSPL C C-------------------------------------------------------------- C C Other variables used inside the subroutine QSPL C INTEGER IX,JX,KX,MX,IY,JY,KY,MY,IZ,JZ,KZ,MZ,II,JJ,KK,MM C C The matrix element B(II,JJ) is located in the array element C B(KK), where C for symmetric matrix B, II.LE.JJ : C KK= (JJ-1)*JJ/2+II C for symmetric matrix B, II.GT.JJ : C KK= (II-1)*II/2+JJ C for nonsymmetric matrix B : C KK= (JJ-1)*NN+II C with NN=NX*NY*NZ being the dimension of the matrix B. C C The matrix element BX(IX,JX) is located in the array element C BX(KX). The meaning of IX,JX,KX is similar as the meaning C of II,JJ,KK in the case of matrix B. C C The matrix element BY(IY,JY) is located in the array element C BZ(KY). The meaning of IY,JY,KY is similar as the meaning C of II,JJ,KK in the case of matrix B. C C The matrix element BZ(IZ,JZ) is located in the array element C BZ(KZ). The meaning of IZ,JZ,KZ is similar as the meaning C of II,JJ,KK in the case of matrix B. C C MM, MX, MY, MZ are auxiliary variables considering the C symmetry of the matrices B, BX, BY, BZ. C C--------------------------------------------------------------- C C Scalar products of B-splines in X-direction KX= 0 MX= NX DO 12 JX=1,NX C Is BX symmetric matrix ? IF(NAX.EQ.NBX) MX=JX DO 11 IX=1,MX KX= KX+1 CALL QSPL(NAX,NBX,IX,JX,NX,X,VX,SIGMA,BX(KX)) C QSPL 11 CONTINUE 12 CONTINUE C C Scalar products of B-splines in Y-direction KY= 0 MY= NY DO 14 JY=1,NY C Is BY symmetric matrix ? IF(NAY.EQ.NBY) MY=JY DO 13 IY=1,MY KY= KY+1 CALL QSPL(NAY,NBY,IY,JY,NY,Y,VY,SIGMA,BY(KY)) C QSPL 13 CONTINUE 14 CONTINUE C C Scalar products of B-splines in Z-direction KZ= 0 MZ= NZ DO 16 JZ=1,NZ C Is BZ symmetric matrix ? IF(NAZ.EQ.NBZ) MZ=JZ DO 15 IZ=1,MZ KZ= KZ+1 CALL QSPL(NAZ,NBZ,IZ,JZ,NZ,Z,VZ,SIGMA,BZ(KZ)) C QSPL 15 CONTINUE 16 CONTINUE C C Scalar products of 3-D B-splines C Is B symmetric matrix ? IF(NAX.EQ.NBX.AND.NAY.EQ.NBY.AND.NAZ.EQ.NBZ) THEN MM= 1 ELSE MM= 0 END IF KK= 0 JJ= 0 DO 27 JZ=1,NZ DO 26 JY=1,NY DO 25 JX=1,NX JJ= JJ+1 II= 0 C Is BZ symmetric matrix ? IF(NAZ.EQ.NBZ) THEN KZ= (JZ-1)*JZ/2 ELSE KZ= (JZ-1)*NZ END IF DO 23 IZ=1,NZ KZ= KZ+1 C Subdiagonal element of matrix BZ IF(NAZ.EQ.NBZ.AND.IZ.GT.JZ) KZ=KZ+IZ-2 C Is BY symmetric matrix ? IF(NAY.EQ.NBY) THEN KY= (JY-1)*JY/2 ELSE KY= (JY-1)*NY END IF DO 22 IY=1,NY KY= KY+1 C Subdiagonal element of matrix BY IF(NAY.EQ.NBY.AND.IY.GT.JY) KY=KY+IY-2 C Is BX symmetric matrix ? IF(NAX.EQ.NBX) THEN KX= (JX-1)*JX/2 ELSE KX= (JX-1)*NX END IF DO 21 IX=1,NX KX= KX+1 C Subdiagonal element of matrix BX IF(NAX.EQ.NBX.AND.IX.GT.JX) KX=KX+IX-2 KK= KK+1 B(KK)= B(KK)+WEIGHT*BX(KX)*BY(KY)*BZ(KZ) II= II+1 IF(MM*II.GE.JJ) GO TO 24 21 CONTINUE 22 CONTINUE 23 CONTINUE 24 CONTINUE 25 CONTINUE 26 CONTINUE 27 CONTINUE C RETURN END C C======================================================================= C C C SUBROUTINE QSPL(NA,NB,IA,IB,N,X,V,SIGMA,Q) C INTEGER NA,NB,IA,IB,N REAL X(N),V(5,N),SIGMA,Q C C Complement to FITPACK C by Alan Kaylor Cline C coded -- January 23, 1994 C by Ludek Klimes C Department of Geophysics C Charles University, Prague C C This subroutine evaluates the Sobolev scalar product C of spline under tension basis functions in one variable C (the Sobolev scalar product consists of integrals of the C products of partial derivatives of the two argument functions) C C On input-- C C NA is the order of the partial derivative of C the first argument function in the scalar product. C C NB is the order of the partial derivative of C the second argument function in the scalar product. C C IA is the index of the first argument function C (1.LE.IA.LE.N). C C IB is the index of the second argument function C (1.LE.IB.LE.N). C C N is the number of grid points. C (N should be at least 1) C C X is the array of the N coordinates of grid points. C These should be strictly increasing. C C V is the array of lengths 5*N, C containing certain coefficients to be used C for the determination of the B-spline under C tension basis. Considered as a 5 by N array, for I = 1, C ... , N, B-spline basis function I is specified by-- C V(1,I) = second derivative at X(I-1), for I .NE. 1, C V(2,I) = second derivative at X(I), for all I, C V(3,I) = second derivative at X(I+1), for I .NE. N, C V(4,I) = function value at X(I-1), for I .NE. 1, C V(5,I) = function value at X(I+1), for I .NE. N, C and the properties that it has-- C 1. Function value 1 at X(i), C 2. Function value and second derivative = 0 at C X(1), ... , X(I-2), and X(I+2), ... , X(N). C In V(5,N) and V(3,N) are contained function value and C second derivative of basis function zero at X(1), C respectively. In V(4,1) and V(1,1) are contained C function value and second derivative of basis function C N+1 at X(N), respectively. Function value and second C derivative of these two basis functions are zero at all C other knots. Only basis function zero has non-zero C second derivative value at X(1) and only basis C function N+1 has non-zero second derivative at X(N). C C SIGMA contains the tension factor. This value indicates C the curviness desired. If ABS(SIGMA) is nearly zero C (e. g. .001) the basis functions are approximately cubic C splines. If ABS(SIGMA) is large (e. g. 50.) the basis C functions are nearly piecewise linear. If SIGMA equals C zero a cubic spline basis results. A standard value for C SIGMA is approximately 1. In absolute value. C C And C C None of the input parameters are altered. C C The parameters N, X, V, and SIGMA C should be input unaltered from the output of VAL3B1 C (SURFB1, CURVB1). C C On output-- C C Q is the integral of the product of NA-th partial C derivative of the IA-th basis function and C NB-th partial derivative of the IB-th spline under C tension basis function. C C This subroutine references package modules QINT, SNHCSH. C EXTERNAL QINT C C--------------------------------------------------------------- C C Other variables used inside the subroutine QSPL: C INTEGER I,J REAL SIGMAP,V1A,V2A,V3A,V4A,V5A,V1B,V2B,V3B,V4B,V5B C C I...Index of the interval. C J...Position of the second B-spline with respect to the C interval I. C SIGMAP...Denormalized tension factor. C V1A,V2A,V3A,V4A,V5A,V1B,V2B,V3B,V4B,V5B...Auxiliary C storage locations for V(1,IA),...,V(5,IB). C C--------------------------------------------------------------- C IF(N.GT.1) GO TO 10 Q = 1. IF(NA.NE.0.OR.NB.NE.0) Q=0. GO TO 90 C 10 SIGMAP= ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) V1A= V(1,IA) V2A= V(2,IA) V3A= V(3,IA) V4A= V(4,IA) V5A= V(5,IA) V1B= V(1,IB) V2B= V(2,IB) V3B= V(3,IB) V4B= V(4,IB) V5B= V(5,IB) Q = 0. C I = IA-2 IF(I.LT.1) GO TO 20 J = I-IB+3 IF(J.LT.1) GO TO 20 IF(J.GT.4) GO TO 90 GO TO (11,12,13,14),J 11 CALL QINT(X(I),X(I+1),0. ,0. ,V4A,V1A,NA, * 0. ,0. ,V4B,V1B,NB,SIGMAP,Q) GO TO 20 12 CALL QINT(X(I),X(I+1),0. ,0. ,V4A,V1A,NA, * V4B,V1B,1. ,V2B,NB,SIGMAP,Q) GO TO 20 13 CALL QINT(X(I),X(I+1),0. ,0. ,V4A,V1A,NA, * 1. ,V2B,V5B,V3B,NB,SIGMAP,Q) GO TO 20 14 CALL QINT(X(I),X(I+1),0. ,0. ,V4A,V1A,NA, * V5B,V3B,0. ,0. ,NB,SIGMAP,Q) C QINT C 20 I = IA-1 IF(I.LT.1) GO TO 30 J = I-IB+3 IF(J.LT.1) GO TO 30 IF(J.GT.4) GO TO 90 GO TO (21,22,23,24),J 21 CALL QINT(X(I),X(I+1),V4A,V1A,1. ,V2A,NA, * 0. ,0. ,V4B,V1B,NB,SIGMAP,Q) GO TO 30 22 CALL QINT(X(I),X(I+1),V4A,V1A,1. ,V2A,NA, * V4B,V1B,1. ,V2B,NB,SIGMAP,Q) GO TO 30 23 CALL QINT(X(I),X(I+1),V4A,V1A,1. ,V2A,NA, * 1. ,V2B,V5B,V3B,NB,SIGMAP,Q) GO TO 30 24 CALL QINT(X(I),X(I+1),V4A,V1A,1. ,V2A,NA, * V5B,V3B,0. ,0. ,NB,SIGMAP,Q) C QINT C 30 I = IA IF(I.GE.N) GO TO 90 J = I-IB+3 IF(J.LT.1) GO TO 40 IF(J.GT.4) GO TO 90 GO TO (31,32,33,34),J 31 CALL QINT(X(I),X(I+1),1. ,V2A,V5A,V3A,NA, * 0. ,0. ,V4B,V1B,NB,SIGMAP,Q) GO TO 40 32 CALL QINT(X(I),X(I+1),1. ,V2A,V5A,V3A,NA, * V4B,V1B,1. ,V2B,NB,SIGMAP,Q) GO TO 40 33 CALL QINT(X(I),X(I+1),1. ,V2A,V5A,V3A,NA, * 1. ,V2B,V5B,V3B,NB,SIGMAP,Q) GO TO 40 34 CALL QINT(X(I),X(I+1),1. ,V2A,V5A,V3A,NA, * V5B,V3B,0. ,0. ,NB,SIGMAP,Q) C QINT C 40 I = IA+1 IF(I.GE.N) GO TO 90 J = I-IB+3 IF(J.LT.1) GO TO 90 IF(J.GT.4) GO TO 90 GO TO (41,42,43,44),J 41 CALL QINT(X(I),X(I+1),V5A,V3A,0. ,0. ,NA, * 0. ,0. ,V4B,V1B,NB,SIGMAP,Q) GO TO 90 42 CALL QINT(X(I),X(I+1),V5A,V3A,0. ,0. ,NA, * V4B,V1B,1. ,V2B,NB,SIGMAP,Q) GO TO 90 43 CALL QINT(X(I),X(I+1),V5A,V3A,0. ,0. ,NA, * 1. ,V2B,V5B,V3B,NB,SIGMAP,Q) GO TO 90 44 CALL QINT(X(I),X(I+1),V5A,V3A,0. ,0. ,NA, * V5B,V3B,0. ,0. ,NB,SIGMAP,Q) C QINT C 90 CONTINUE RETURN END C C======================================================================= C C C SUBROUTINE QINT(X1,X2,FA1,DA1,FA2,DA2,NA, * FB1,DB1,FB2,DB2,NB,SIGMAP,Q) C INTEGER NA,NB REAL X1,X2,FA1,DA1,FA2,DA2,FB1,DB1,FB2,DB2,SIGMAP,Q C C Complement to FITPACK C by Alan Kaylor Cline C coded -- January 23, 1994 C by Ludek Klimes C Department of Geophysics C Charles University, Prague C C This subroutine evaluates the integral of the product C of the given derivatives of the two given cubic functions C or spline under tension basis functions in one variable, C over a single specified interval. C C On input-- C C X1, X2 endpoints of the given interval. C C FA1, DA1 function value and second derivative of the C first given function at X1. C C FA2, DA2 function value and second derivative of the C first given function at X2. C C NA is the order of the partial derivative of C the first argument function in the scalar product. C C FB1, DB1, FB2, DB2 the same as FA1, DA1, FA2, DA2, but C for the second given function. C C NB is the order of the partial derivative of C the second argument function in the scalar product. C C SIGMAP is the denormalized tension factor. C C And C C None of the input parameters are altered. C C On output-- C C Q is the integral of the product of NA-th partial C derivative of the first function and C NB-th partial derivative of the second function, C over the interval X1,X2. C C This subroutine references package module SNHCSH. C EXTERNAL SNHCSH C C--------------------------------------------------------------- C C Other variables used inside the subroutine QINT: C INTEGER MA,MB,M REAL QQ,H,SH,CH,SH1,CH1,SIGMA2 REAL A1,A2,A3,A4,B1,B2,B3,B4,AB11,AB21,AB12,AB22 C C--------------------------------------------------------------- C MA= MOD(NA,2) MB= MOD(NB,2) M = MA+MA+MB+1 QQ= 0. C IF(SIGMAP.NE.0.) GO TO 40 C C No tension: H = X2-X1 IF(NA.LE.3.AND.NB.LE.3) GO TO 1 GO TO 91 1 IF(NA.LE.1) GO TO 3 C Coefficients of linear function A3= DA2/H A4=-DA1/H IF(NB.LE.1) GO TO 2 C Coefficients of linear function B3= DB2/H B4=-DB1/H GO TO 80 2 CONTINUE C Coefficients of cubic and linear functions B1= DB2/H B2=-DB1/H B3= FB2/H-DB2*H/6. B4=-FB1/H+DB1*H/6. GO TO 30 3 CONTINUE C Coefficients of cubic and linear functions A1= DA2/H A2=-DA1/H A3= FA2/H-DA2*H/6. A4=-FA1/H+DA1*H/6. IF(NB.LE.1) GO TO 4 C Coefficients of linear function B3= DB2/H B4=-DB1/H GO TO 20 4 CONTINUE C Coefficients of cubic and linear functions B1= DB2/H B2=-DB1/H B3= FB2/H-DB2*H/6. B4=-FB1/H+DB1*H/6. C C Integrals of (cubic function)*(cubic function): GO TO (11,12,13,14),M C (even derivative)*(even derivative) 11 AB11= (H**7)/252. AB21=-(H**7)/5040. AB12= AB21 AB22= AB11 GO TO 15 C (even derivative)*(odd derivative) 12 AB11= (H**6)/72. AB21=-(H**6)/720. AB12=-AB21 AB22=-AB11 GO TO 15 C (odd derivative)*(even derivative) 13 AB11= (H**6)/72. AB21= (H**6)/720. AB12=-AB21 AB22=-AB11 GO TO 15 C (odd derivative)*(odd derivative) 14 AB11= (H**5)/20. AB21= (H**5)/120. AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 15 QQ=QQ+A1*(AB11*B1+AB12*B2)+A2*(AB21*B1+AB22*B2) C C Integrals of (cubic function)*(linear function): 20 GO TO (21,22,23,24),M C (even derivative)*(even derivative) 21 AB11= (H**5)/30. AB21=-(H**5)/120. AB12= AB21 AB22= AB11 GO TO 25 C (even derivative)*(odd derivative) 22 AB11= (H**4)/24. AB21=-(H**4)/24. AB12=-AB21 AB22=-AB11 GO TO 25 C (odd derivative)*(even derivative) 23 AB11= (H**4)/8. AB21= (H**4)/24. AB12=-AB21 AB22=-AB11 GO TO 25 C (odd derivative)*(odd derivative) 24 AB11= (H**3)/6. AB21= (H**3)/6. AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 25 QQ=QQ+A1*(AB11*B3+AB12*B4)+A2*(AB21*B3+AB22*B4) C IF(NB.GT.1) GO TO 80 C C Integrals of (linear function)*(cubic function): 30 GO TO (31,32,33,34),M C (even derivative)*(even derivative) 31 AB11= (H**5)/30. AB21=-(H**5)/120. AB12= AB21 AB22= AB11 GO TO 35 C (even derivative)*(odd derivative) 32 AB11= (H**4)/8. AB21=-(H**4)/24. AB12=-AB21 AB22=-AB11 GO TO 35 C (odd derivative)*(even derivative) 33 AB11= (H**4)/24. AB21= (H**4)/24. AB12=-AB21 AB22=-AB11 GO TO 35 C (odd derivative)*(odd derivative) 34 AB11= (H**3)/6. AB21= (H**3)/6. AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 35 QQ=QQ+A3*(AB11*B1+AB12*B2)+A4*(AB21*B1+AB22*B2) GO TO 80 C C C Nonzero tension: 40 H = SIGMAP*(X2-X1) CALL SNHCSH(SH1,CH1,H,0) C SNHCSH SH= SH1+H CH= CH1+1. SIGMA2= SIGMAP*SIGMAP C C Coefficients of hyperbolic functions (multiplied by SH) A1= DA2/SIGMA2 A2=-DA1/SIGMA2 B1= DB2/SIGMA2 B2=-DB1/SIGMA2 C C Doubled C integrals of (hyperbolic function)*(hyperbolic function): GO TO (51,52,53,54),M C (even derivative)*(even derivative) 51 AB11= CH*SH1+H*CH1 AB21= SH1-H*CH1 AB12= AB21 AB22= AB11 GO TO 55 C (even derivative)*(odd derivative) 52 AB11= SH*SH AB21= -H*SH AB12=-AB21 AB22=-AB11 GO TO 55 C (odd derivative)*(even derivative) 53 AB11= SH*SH AB21= H*SH AB12=-AB21 AB22=-AB11 GO TO 55 C (odd derivative)*(odd derivative) 54 AB11= SH*CH+H AB21= SH+H*CH AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 55 QQ=QQ+(A1*(AB11*B1+AB12*B2)+A2*(AB21*B1+AB22*B2))/(2.*SH*SH) C IF(NB.GT.1) GO TO 70 C C Coefficients of linear function B3= ( FB2-B1)/H B4= (-FB1-B2)/H C C Integrals of (hyperbolic function)*(linear function): GO TO (61,62,63,64),M C (even derivative)*(even derivative) 61 AB11= H*CH1-SH1 AB21= -SH1 AB12= AB21 AB22= AB11 GO TO 65 C (even derivative)*(odd derivative) 62 AB11= CH1 AB21=-CH1 AB12=-AB21 AB22=-AB11 GO TO 65 C (odd derivative)*(even derivative) 63 AB11= H*SH-CH1 AB21= CH1 AB12=-AB21 AB22=-AB11 GO TO 65 C (odd derivative)*(odd derivative) 64 AB11= SH AB21= SH AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 65 QQ=QQ+(A1*(AB11*B3+AB12*B4)+A2*(AB21*B3+AB22*B4))/SH C 70 IF(NA.GT.1) GO TO 90 C C Coefficients of linear function A3= ( FA2-A1)/H A4= (-FA1-A2)/H C C Integrals of (linear function)*(hyperbolic function): GO TO (71,72,73,74),M C (even derivative)*(even derivative) 71 AB11= H*CH1-SH1 AB21= -SH1 AB12= AB21 AB22= AB11 GO TO 75 C (even derivative)*(odd derivative) 72 AB11= H*SH-CH1 AB21= -CH1 AB12=-AB21 AB22=-AB11 GO TO 75 C (odd derivative)*(even derivative) 73 AB11= CH1 AB21= CH1 AB12=-AB21 AB22=-AB11 GO TO 75 C (odd derivative)*(odd derivative) 74 AB11= SH AB21= SH AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 75 QQ=QQ+(A3*(AB11*B1+AB12*B2)+A4*(AB21*B1+AB22*B2))/SH C IF(NB.GT.1) GO TO 90 C C Integrals of (linear function)*(linear function): 80 GO TO (81,82,83,84),M C (even derivative)*(even derivative) 81 AB11= (H**3)/3. AB21=-(H**3)/6. AB12= AB21 AB22= AB11 GO TO 85 C (even derivative)*(odd derivative) 82 AB11= (H**2)/2. AB21=-AB11 AB12=-AB21 AB22=-AB11 GO TO 85 C (odd derivative)*(even derivative) 83 AB11= (H**2)/2. AB21= AB11 AB12=-AB21 AB22=-AB11 GO TO 85 C (odd derivative)*(odd derivative) 84 AB11= H AB21= H AB12= AB21 AB22= AB11 C Accumulation of the computed integral: 85 QQ=QQ+A3*(AB11*B3+AB12*B4)+A4*(AB21*B3+AB22*B4) C C Transformation from independent variable SIGMAP*X to X 90 IF(SIGMAP.NE.0.) QQ=QQ*SIGMAP**(NA+NB-1) 91 Q= Q+QQ RETURN END C C======================================================================= Csrfc.for 0100666 0000765 0000765 00000024623 06367275454 012127 0 ustar bulant bulant CC Subroutine file 'srfc.for' for specification and interpolation of C smooth surfaces in the model in rectangular grids. C C Date: 1996, September 30 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C SRFC1...Subroutine reading the input data for smooth surfaces. C SRFC1 C SRFC2...Subroutine evaluating the function values and their first C and second derivatives. Outside the specified rectangular C grid, the functions are continued smoothly. C SRFC2 C Subroutines SRFC1 and SRFC2 supporting the complete ray tracing C algorithm only mediate the work of subroutines VAL1 and VAL2 which C must be appended. In addition, subroutines CURVN1 (or its alternative C CURVB1), CURV2D (or its alternative CURVBD), SURFB1, SURFBD, VAL3B1, C VAL3BD, VGEN, TERMS, SNHCSH, TRIDEC, TRISOL, DSPLNZ, INTRVL from the C subroutine package 'FITPACK' by Alan Kaylor Cline, Department of C Computer Sciences, University of Texas at Austin, are used. In the C complete ray tracing, this software file 'srfc.for' may be replaced C by any user-defined package containing subroutines SRFC1 and SRFC2 C with the same number, type and meaning of their parameters as in this C file. C C If model variations are taken into account: C Model variations are assumed to be stored while evaluating the C function describing a given surface during the invocation of C subroutine VAL of file 'val.for' and subsequent routines of file C 'fit.for'. The variations are assumed to be stored in register 1 C of the system VAR*. C C....................................................................... C C C Input data (read in by subroutine SRFC1): C These input data define the surfaces. They are read in by C subroutine SRFC1. The number nsrfc of the surfaces to be defined C is an input argument of subroutine SRFC1. The data are read in by C the list directed input (free format). C (1) NSRFC-times (i.e. once for each surface) input data (1A)+(1B): C (1A) TEXTG,ISRFC C Identification of the surface. C TEXTG...Any string. Its first 3 characters must differ from 'END'. C ISRFC...Index of the surface. C (1B) 'Input data for one surface', see below. C (2) TEXTE,AUX C End of data. C TEXTE...String, the first 3 characters of which must be upper-case C 'END'. C AUX... Any number or a slash. C For an example refer to the sample input data for the model. C C Input data for one surface: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new read statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise, the input parameter is of the type REAL. C (1) IVAR1,IVAR2,IVAR3,SIGMA,POWERW,/ C The form of the function. C IVAR1,IVAR2,IVAR3... Denote the form of the function. The function C must be of the form C F(X1,X2,X3) = W(A1,A2,A3)-B1-B2-B3 . C X1, X2, X3 are the general coordinates. Each of A1, A2, C A3, B1, B2, B3 must be either: (a) one of general C coordinates X1, X2, X3, or (b) must be left out. At most C 3 of parameters A1-B3 may be of kind (a). Note that IVAR1 C controls the type of A1 and B1, IVAR2 controls the type of C A2 and B2, IVAR3 controls the type of A3 and B3. C For IVAR1.EQ.0: A1, B1 are empty (left out), C for IVAR1.EQ.1: A1=X1, B1 is empty, C for IVAR1.EQ.2: A1=X2, B1 is empty, C for IVAR1.EQ.3: A1=X3, B1 is empty, C for IVAR1.EQ.-1: B1=X1, A1 is empty, C for IVAR1.EQ.-2: B1=X2, A1 is empty, C for IVAR1.EQ.-3: B1=X3, A1 is empty, C the meaning of the parameters IVAR2, IVAR3 is similar. C Examples: C IVAR1: IVAR2: IVAR3: the form of the function: C 1 2 3 F(X1,X2,X3)=W(X1,X2,X3) C 3 1 2 F(X1,X2,X3)=W(X3,X1,X2) C 1 2 0 F(X1,X2,X3)=W(X1,X2) C 1 2 -3 F(X1,X2,X3)=W(X1,X2)-X3 C 1 -3 2 F(X1,X2,X3)=W(X1,X2)-X3 C Function W is interpolated by means of splines under C tension. C SIGMA...Is the tension factor (its sign is ignored). This value C indicates the curviness desired. If ABS(SIGMA) is nearly C zero (e.g. 0.001), the resulting surface is approximately C the tensor product of cubic splines. If ABS(SIGMA) is C large (e.g. 50.), the resulting surface is approximately C tri-linear. If SIGMA equals zero, tensor products of C cubic splines result. A recommended value for SIGMA is C approximately 1. In absolute value. C POWERW..Given grid values (6) correspond to the POWERW-th power of C interpolated function W. The given grid values (6) are C thus raised to the (1/POWERW)-th power immediately after C reading and then interpolated. POWERW=1 is recommended. C /... Obligatory slash at the end of line for future extensions. C Default: IVAR1=0, IVAR2=0, IVAR3=0, SIGMA=0, POWERW=1. C (2) NX(1),...,NX(NVAR) C The numbers of grid coordinates for the interpolation. C This input is performed if at least one of IVAR1, IVAR2, IVAR3 is C positive. C Each of NX(1),...,NX(NVAR) corresponds to one positive value of C IVAR1, IVAR2, IVAR3 and specifies the number of grid coordinates C corresponding to that independent variable of function W, see (1). C The sign of NX(1),...,NX(NVAR) is ignored. NVAR (.LE.3) is the C number of positive values of the above quantities IVAR1, IVAR2, C IVAR3, i.e. The number of independent variables of function W, C see (1). C (3) X1(1),...,X1(NX(1)) C The grid coordinates corresponding to the first independent C variable of function W, see (1). C This input is performed if NX(1) is specified, see (2), and is not C zero. The grid coordinates may be specified in any order. C (4) X2(1),...,X2(NX(2)) C The grid coordinates corresponding to the second independent C variable of function W, see (1). C This input is performed if NX(2) is specified, see (2), and is not C zero. The grid coordinates may be specified in any order. C (5) X3(1),...,X3(NX(3)) C The grid coordinates corresponding to the third independent C variable of function W, see (1). C This input is performed if NX(3) is specified, see (2), and is not C zero. The grid coordinates may be specified in any order. C (6) (((W(I,J,K),I=1,MAX(NX(1),1)),J=1,MAX(NX(2),1)),K=1,MAX(NX(3),1)) C The values of function W at grid points. Function value W(I,J,K) C corresponds to point (X1(I),X2(J),X3(K)). C C======================================================================= C C C SUBROUTINE SRFC1(LUN,NSRFC) INTEGER LUN,NSRFC C C This subroutine reads the input data for the smooth surfaces, C determines the parameters necessary to compute an interpolatory C function on a three dimensional rectangular grid, and stores them in C the memory. The function determined can be represented as a tensor C product of splines under tension. For actual mapping of points it is C necessary to call the subroutine SRFC2, which also returns the first C and second partial derivatives. Subroutine SRFC1 may be called C several times. The surfaces are indexed successively, following the C surfaces defined during the previous invocations. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C NSRFC...Number of the surfaces for which the input data are C specified during the current invocation of SRFC1. C None of the input parameters are altered. C C No output. C C Subroutines and external functions required: EXTERNAL VAL1 C VAL1, SORTV, READV... File 'val.for'. C CURVN1 or CURVB1 (alternatives), SURFB1, VAL3B1, SNHCSH, VGEN, C TERMS, TRIDEC, TRISOL... Subroutine package 'FITPACK' C (file 'fit.for'). C C Date: 1992, December 31 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: CHARACTER*3 TFUNCT(1) DATA TFUNCT/' '/ C CALL VAL1(LUN,1,NSRFC,1,TFUNCT) RETURN END C C======================================================================= C C C SUBROUTINE SRFC2(ISRFC,COOR,F) INTEGER ISRFC REAL COOR(3),F(10) C C This subroutine evaluates the functions describing various smooth C surfaces in the model at a given point. The three first and six second C partial derivatives are also evaluated. The specified functions are C represented as a tensor product of splines under tension. The C coefficients of these functions are prepared in subroutine SRFC1, in C which the input data concerning the function of each surface are read C in. C C Input: C ISRFC...Index of a surface. C COOR... Array containing coordinates X1, X2, X3 of the given C point. C None of the input parameters are altered. C C Output: C F... The value and the first and second partial derivatives F, C F1, F2, F3, F11, F12, F22, F13, F23, F33 of the function C F(X1,X2,X3) determining the surface ISRFC at the given C point. C C Subroutines and external functions required: EXTERNAL VAL2 C VAL2... File 'val.for'. C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1996, September 30 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage location: REAL POWER(1) C CALL VAL2(1,IABS(ISRFC),1,COOR,F,POWER) RETURN END C C======================================================================= Cval.for 0100666 0000765 0000765 00000127674 06767630516 011764 0 ustar bulant bulant CC Subroutine file 'val.for' for function specification and interpolation C - designed to perform the interpolation of a set of functions in a C rectangular grid. C C Date: 1999, September 15 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C VALB... Block data subroutine initiating common block /VALC/ to C store the data describing the interpolated functions. C VALB C VAL1... Subroutine designed to read the input data for the C functions, to compute the coefficients of the expansion C and to store them in the memory. C VAL1 C SORTV...Auxiliary subroutine to subroutine VAL1. C SORTV C READV...Auxiliary subroutine to subroutine VAL1. C READV C VAL2... Subroutine evaluating the functions including their first C and second derivatives. The functions may be used to C specify various surfaces in the model, the space C distributions of various parameters, e.t.c. The functions C are represented as a tensor product of splines under C tension of at most 3 independent variables (i.e. a linear C combination of products of B-splines under tension of at C most 3 independent variables). Outside the specified C rectangular grid, the functions are extrapolated by their C analytic continuation. See lines of subroutine VAL2 with C 'CV3' in first 3 columns for comparison with the kind of C extrapolation used in old versions (outside the specified C rectangular grid, the functions were linear along straight C lines perpendicular to the boundary of the grid). The C functions may be embedded: the independent variable of C the function may be another function of the same group C (see below) foregoing in the input data. C VAL2 C Subroutines of this file employ routines CURVN1 (or its alternative C CURVB1), CURV2D (or its alternative CURVBD), SURFB1, SURFBD, VAL3B1, C VAL3BD, VGEN, TERMS, SNHCSH, TRIDEC, TRISOL, DSPLNZ, INTRVL from the C subroutine package 'FITPACK' by Alan Kaylor Cline, Department of C Computer Sciences, University of Texas at Austin. C C Note: C The lines denoted by '*V' in the first two columns of file C 'val.for' in subroutine VAL2 are designed to calculate the model C variations with respect to the model parameters. C File 'valv.for', intended for the model inversion, is created C from 'val.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C C....................................................................... C C Classes of functions: C The interpolated functions are divided into some classes, e.g., C functions describing interfaces, functions describing the medium C parameters, functions describing the properties of the source, C etc. The number MCLASS of the defined classes is stored in the C memory and is initially zero. The new class may be defined by C means of the invocation of subroutine VAL1, see its input argument C ICLASS. During one invocation of VAL1, only the groups of C functions relevant to one class may be defined. Subroutine VAL1 C may be called several times even for one class to define its C groups successively, stage by stage. In this case, the input data C for the groups of functions relevant to one class may be read in C from various files. C C Groups of functions: C The interpolated functions of each class are divided into some C groups. For instance, the class of functions describing the medium C parameters is divided into groups corresponding to individual C complex blocks. The individual groups need not contain the same C number of functions. The group corresponding to a complex block C may contain e.g. the functions describing P-wave velocity, S-wave C velocity, density, etc. The functions not specified by the input C data but required by the program are defined and are zero. C C C Input data (read in by subroutine VAL1): C These input data define the groups of functions from the specified C class. The index ICLASS of the class is an input argument of C subroutine VAL1. If the class is not defined by a previous C invocation of VAL1, it is created. The number NGROUP of the C groups to be defined is an input argument of subroutine VAL1. The C data are read in by the list directed input (free format). C (1) NGROUP-times (i.e. once for each group of functions) input data C (1A)+(1B): C (1A) TEXTG,IGROUP C Identification of the group. C TEXTG...Any string. Its first 3 characters must differ from 'END' C and from any string identifying a physical quantity, C defined by input array TFUNCT of subroutine VAL1 (see C below). C IGROUP..Sequential number of the group in the class. C (1B) Several times Input data for one function, C see below. C If input array TFUNCT of subroutine VAL1 is fully filled by C spaces, 'Input data for one function' must be included C just NFUNCT-times (NFUNCT is an input argument of C subroutine VAL1). In this case, the input functions are C not identified by a string (see (1) of 'Input data for one C function'), their number and order must be a priori known. C This is, for instance, the case of smooth surfaces: each C group corresponds to one surface and contains just one C function. The index of the surface coincides with the C index of the group, and no identification and sorting of C functions inside a group is needed. C If input array TFUNCT of subroutine VAL1 is not fully filled by C spaces, 'Input data for one function' may be included C N-times, where 0.LE.N.LE.NFUNCT. In this case, the input C functions of individual groups are identified by a string C (see (1) of 'Input data for one function') in the input C data, their number and order may be arbitrary (note that C their number must be less than or equal to NFUNCT). This C is, for instance, the case of complex blocks: each group C corresponds to one complex block and contains some number C of functions describing material parameters. Individual C functions (material parameters) are identified by a string C in the input data. C (2) TEXTE,AUX C End of data. C TEXTE...String, the first 3 characters of which must be upper-case C 'END'. C AUX... Any number or a slash. C C C Input data for one function: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new READ statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise (except TEXTF), the input parameter is of the C type REAL. C (1) TEXTF,POWER C Physical meaning of the function. This input is not performed if C input character array TFUNCT of subroutine VAL1 (see below) is C fully filled by spaces. C TEXTF...String identifying which physical quantity the function C describes. Only the first 3 characters are significant. C The first 3 characters of the string must not be equal to C 'END'. The set of meaningful strings is defined by input C array TFUNCT of subroutine VAL1 (see below). C POWER...The specified function is equal to the POWER-th power of C the physical quantity. C Default: POWER=1. C (2) IVAR1,IVAR2,IVAR3,SIGMA,POWERW,/ C The form of the function. C IVAR1,IVAR2,IVAR3... Denote the form of the function. The function C must be of the form C F(X1,X2,X3) =W(A1,A2,A3)-B1-B2-B3 . C X1, X2, X3 are the general coordinates. Each of A1, A2, C A3, B1, B2, B3 must be either: (a) one of general C coordinates X1, X2, X3, (b) another previously defined C function F(X1,X2,X3) of the same group, or (c) must be C left out. At most 3 of parameters A1-B3 may be of kind C (a) or (b). Note that IVAR1 controls the type of A1 and C B1, IVAR2 controls the type of A2 and B2, IVAR3 controls C the type of A3 and B3. C For IVAR1.EQ.0: A1, B1 are empty (left out), C for IVAR1.EQ.1: A1=X1, B1 is empty, C for IVAR1.EQ.2: A1=X2, B1 is empty, C for IVAR1.EQ.3: A1=X3, B1 is empty, C for IVAR1.GE.4: A1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same group defined in the input C data as the (IVAR1-3)-th function of the group. B1 is C empty, C for IVAR1.EQ.-1: B1=X1, A1 is empty, C for IVAR1.EQ.-2: B1=X2, A1 is empty, C for IVAR1.EQ.-3: B1=X3, A1 is empty, C for IVAR1.LE.-4: B1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same group defined in the input C data as the (-IVAR1-3)-th function of the group. A1 is C empty. C The meaning of the parameters IVAR2, IVAR3 is similar. C Examples: C IVAR1: IVAR2: IVAR3: the form of the function: C 1 2 3 F(X1,X2,X3)=W(X1,X2,X3) C 3 1 2 F(X1,X2,X3)=W(X3,X1,X2) C 1 2 0 F(X1,X2,X3)=W(X1,X2) C 1 2 -3 F(X1,X2,X3)=W(X1,X2)-X3 C 1 -3 2 F(X1,X2,X3)=W(X1,X2)-X3 C 5 0 0 F(X1,X2,X3)=W(F2(X1,X2,X3)), where C F2(X1,X2,X3) is the second function of the group defined C in the input data. Function W is interpolated by means of C splines under tension. C SIGMA...Is the tension factor (its sign is ignored). This value C indicates the curviness desired. If ABS(SIGMA) is nearly C zero (e.g. 0.001), the resulting surface is approximately C the tensor product of cubic splines. If ABS(SIGMA) is C large (e.g. 50.), the resulting surface is approximately C tri-linear. If SIGMA equals zero, tensor products of C cubic splines result. A recommended value for SIGMA is C approximately 1. In absolute value. C POWERW..Given grid values (7) correspond to the POWERW-th power of C interpolated function W. The given grid values (7) are C thus raised to the (1/POWERW)-th power immediately after C reading and then interpolated. C /... Obligatory slash at the end of line for future extensions. C Default: IVAR1=0, IVAR2=0, IVAR3=0, SIGMA=0, POWERW=1. C (3) NX(1),...,NX(NVAR) C The numbers of grid coordinates for the interpolation. C This input is performed if at least one of IVAR1, IVAR2, IVAR3 is C positive. C Each of NX(1),...,NX(NVAR) corresponds to one positive value of C IVAR1, IVAR2, IVAR3 and specifies the number of grid coordinates C corresponding to that independent variable of function W, see (2). C The sign of NX(1),...,NX(NVAR) is ignored. NVAR (.LE.3) is the C number of positive values of the above quantities IVAR1, IVAR2, C IVAR3, i.e. the number of independent variables of function W, C see (2). C (4) X1(1),...,X1(NX(1)) C The grid coordinates corresponding to the first independent C variable of function W, see (2). C This input is performed if NX(1) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (5) X2(1),...,X2(NX(2)) C The grid coordinates corresponding to the second independent C variable of function W, see (2). C This input is performed if NX(2) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (6) X3(1),...,X3(NX(3)) C The grid coordinates corresponding to the third independent C variable of function W, see (2). C This input is performed if NX(3) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (7) (((W(I,J,K),I=1,MAX(NX(1),1)),J=1,MAX(NX(2),1)),K=1,MAX(NX(3),1)) C The values of the POWERW-th power of function W at grid points. C Function value W(I,J,K) corresponds to point (X1(I),X2(J),X3(K)). C C======================================================================= C C C C Storage in the memory: C The parameters describing the interpolated functions are stored C in common block /VALC/ initialized in the following subroutine: C ------------------------------------------------------------------ BLOCK DATA VALB INCLUDE 'val.inc' C val.inc DATA IPAR(0)/0/ END C ------------------------------------------------------------------ C C======================================================================= C C C SUBROUTINE VAL1(LUN,ICLASS,NGROUP,NFUNCT,TFUNCT) INTEGER LUN,ICLASS,NGROUP,NFUNCT CHARACTER*(*) TFUNCT(NFUNCT) C C This subroutine reads the input data for a set of functions, C determines the parameters necessary to compute an interpolatory C function on a three-dimensional rectangular grid, and stores them in C the memory. The function determined can be represented as a tensor C product of splines under tension of at most 3 independent variables C (i.e. a linear combination of products of B-splines under tension of C at most 3 independent variables). The functions may be embedded: the C independent variable of the function may be another function of the C same group foregoing in the input data. For actual mapping of points C it is necessary to call the subroutine VAL2, which also returns the C first and second partial derivatives. Subroutine VAL1 may be called C several times. The groups in the class are indexed successively, C following the groups of the class defined during the previous C invocations. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C ICLASS..Index of the class of the functions to be specified. The C classes are indexed by integers starting from 1. C NGROUP..Number of groups of functions to be specified during the C current invocation of VAL1. The groups of each class are C indexed by integers starting from 1. If some groups of C functions of the ICLASS-th class were specified in the C previous invocation of VAL1, the groups of functions now C read in are appended to them and are indexed following C them. C NFUNCT..Maximum number of functions to be specified for each C group. The actual number of specified functions may be C different for different groups. However, it must be less C than or equal to NFUNCT. C TFUNCT..Strings identifying the functions specified in the input C data. The function identified in the input data by string C TFUNCT(I) is associated with integer I. This integer C identifies what the function describes. C None of the input parameters are altered. C C No output. C C Common block: INCLUDE 'val.inc' C val.inc C All the storage locations of the common block are defined in this C subroutine. C C Subroutines and external functions required: * EXTERNAL CURVN1 EXTERNAL CURVB1 EXTERNAL VALB,SURFB1,VAL3B1,SORTV,READV C VALB... Block data subroutine of this file. C CURVN1 or CURVB1 (alternatives), SURFB1, VAL3B1, SNHCSH, VGEN, C TERMS, TRIDEC, TRISOL... Subroutine package 'FITPACK' C (file 'fit.for'). C SORTV, READV... This file. C C Date: 1999, September 15 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C LOGICAL WHAT INTEGER MCLASS,MGROUP,MFUNCT,LADR,MADR,MAXADR INTEGER KCLASS,KGROUP,KFUNCT,KADR,NVAR CHARACTER*3 TEXT REAL GROUP,SIGMA,POWERW INTEGER LX(3),LX1,LX2,LX3 EQUIVALENCE (LX(1),LX1),(LX(2),LX2),(LX(3),LX3) INTEGER NX(3),NX1,NX2,NX3 EQUIVALENCE (NX(1),NX1),(NX(2),NX2),(NX(3),NX3) INTEGER JADR(7),JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7 EQUIVALENCE (JADR(1),JADR1),(JADR(2),JADR2),(JADR(3),JADR3) EQUIVALENCE (JADR(4),JADR4),(JADR(5),JADR5),(JADR(6),JADR6) EQUIVALENCE (JADR(7),JADR7) INTEGER IGROUP,IFUNCT,IERR,I,J,L,N C C WHAT... Flag if the physical meaning of the functions is included C in the input data. C MCLASS,MGROUP,MFUNCT,LADR,MADR,MAXADR... Positions in the memory. C KCLASS,KGROUP,KFUNCT,KADR... Shifts in the memory. C NVAR... Number of the independent variables A1, A2, A3 of the C interpolated function W. C TEXT... String identifying the current group or the current C function. C GROUP...Index of the current group or power of the physical C quantity. C SIGMA...Tension factor. C POWERW..Given grid values (7) are raised to the (1/POWERW)-th C power immediately after reading and then interpolated. C LX=(LX1,LX2,LX3)... Addresses of auxiliary storage locations for C reordering the grid coordinates. C NX=(NX1,NX2,NX3)... Numbers of grid lines. C JADR=(JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7)... Addresses of C parameters describing the interpolated function (grid C coordinates, B-spline coefficients, B-spline basis C functions). C IGROUP,IFUNCT... Do loop variables. C IERR... Local variable to check the proper function of called C subroutines. C I,J,L,N... Local auxiliary variables. C C....................................................................... C C Flag if the physical meaning of the functions is included in the C input data: WHAT=.FALSE. DO 10 I=1,NFUNCT IF(TFUNCT(I).NE.' ') WHAT=.TRUE. 10 CONTINUE C C Positions in the memory: IF(ICLASS.GT.IPAR(0)) THEN C New class: MCLASS=IPAR(0) KCLASS=ICLASS-MCLASS ELSE C Old class: MCLASS=ICLASS KCLASS=0 END IF MGROUP=IPAR(MCLASS) KGROUP=KCLASS+NGROUP MFUNCT=IPAR(MGROUP) KFUNCT=KGROUP+NGROUP*NFUNCT MADR=IPAR(MFUNCT) KADR=NPAR-IPAR(IPAR(IPAR(IPAR(0)))) IF(KADR.LT.KFUNCT) GO TO 99 C Upper bound of the available memory MAXADR=MADR+KADR C C Movement in the memory: DO 11 I=IPAR(IPAR(IPAR(IPAR(0)))),MADR+1,-1 IPAR(I+KADR)=IPAR(I) 11 CONTINUE DO 12 I=MADR,IPAR(IPAR(IPAR(0)))+1,-1 IPAR(I+KFUNCT)=IPAR(I) 12 CONTINUE DO 13 I=IPAR(IPAR(IPAR(0))),MFUNCT+1,-1 IPAR(I+KFUNCT)=IPAR(I)+KADR 13 CONTINUE MADR=MADR+KFUNCT DO 14 I=MFUNCT,MGROUP+1,-1 IPAR(I+KGROUP)=IPAR(I)+KFUNCT 14 CONTINUE MFUNCT=MFUNCT+KGROUP DO 15 I=MGROUP,MCLASS+1,-1 IPAR(I+KCLASS)=IPAR(I)+KGROUP 15 CONTINUE MGROUP=MGROUP+KCLASS DO 16 I=0,MCLASS IPAR(I)=IPAR(I)+KCLASS 16 CONTINUE C New classes: DO 17 I=MCLASS+1,ICLASS IPAR(I)=IPAR(MCLASS) 17 CONTINUE C Number of previously stored groups of functions of the class IGROUP=IPAR(ICLASS)-IPAR(ICLASS-1) IPAR(ICLASS)=IPAR(ICLASS)+NGROUP C New groups: DO 18 I=MGROUP+1,MGROUP+NGROUP IPAR(I)=IPAR(I-1)+NFUNCT 18 CONTINUE C C Loop for groups of functions: GROUP=1. READ(LUN,*) TEXT,GROUP DO 90 IGROUP=IGROUP+1,IGROUP+NGROUP IF(TEXT.EQ.'END') THEN C 351 CALL ERROR('351 in VAL1: End of input functions encountered') C End of input functions encountered before all NGROUP C groups of functions are defined in the input data. ELSE IF(INT(GROUP+0.5).NE.IGROUP) THEN C 352 CALL ERROR('352 in VAL1: Improper index of the group') C Improper index of the group of input functions in the C input data. END IF C Loop for functions of the current group: DO 80 IFUNCT=1,NFUNCT C Physical meaning of the function: IF(WHAT) THEN GROUP=1. READ(LUN,*) TEXT,GROUP DO 21 I=1,NFUNCT IF(TFUNCT(I).EQ.TEXT) THEN MADR=MADR+2 IF(MADR.GT.MAXADR) GO TO 99 IPAR(MADR-1)=I RPAR(MADR)=GROUP GO TO 22 END IF 21 CONTINUE GO TO 81 22 CONTINUE ELSE MADR=MADR+2 IF(MADR.GT.MAXADR) GO TO 99 IPAR(MADR-1)=IFUNCT RPAR(MADR)=1. END IF C C Form of the function: LADR=MADR+1 MADR=MADR+4 IF(MADR.GT.MAXADR) GO TO 99 IPAR(LADR) =0 IPAR(LADR+1)=0 IPAR(LADR+2)=0 RPAR(MADR) =0. POWERW =1. READ(LUN,*) * IPAR(LADR),IPAR(LADR+1),IPAR(LADR+2),RPAR(MADR),POWERW SIGMA=RPAR(MADR) IF(POWERW.EQ.0.) THEN C 359 CALL ERROR('359 in VAL1: Zero POWERW in input data') C Zero POWERW in input data describing B-spline interpolation C of functions used to specify surfaces or material parameters C in the model or initial line or surface source. C See input data for one function, C line (2). END IF C Number of independent variables: NVAR=0 DO 23 I=LADR,LADR+2 IF(IPAR(I).GT.0) NVAR=NVAR+1 23 CONTINUE C C Numbers of grid coordinates: LADR=MADR+1 MADR=MADR+NVAR IF(MADR.GT.MAXADR) GO TO 99 IF(LADR.LE.MADR) THEN READ(LUN,*) (IPAR(I),I=LADR,MADR) END IF C C Reading grid coordinates: L=MAXADR+1 NVAR=0 DO 24 J=LADR,MADR N=IABS(IPAR(J)) IF(N.GT.0) THEN LADR=MADR+1 MADR=MADR+N IF(N.EQ.1) THEN IF(MADR.GE.L-1) GO TO 99 READ(LUN,*) RPAR(LADR) ELSE L=L-N IF(MADR+N.GE.L-1) GO TO 99 NVAR=NVAR+1 NX(NVAR)=N LX(NVAR)=L JADR(NVAR)=LADR READ(LUN,*) (RPAR(I),I=MADR+1,MADR+N) CALL SORTV(N,RPAR(MADR+1),RPAR(LADR),IPAR(L)) END IF END IF 24 CONTINUE DO 25 I=NVAR+1,3 NX(I)=1 LX(I)=L-1 IPAR(L-1)=1 25 CONTINUE C C Reading grid values: JADR4=MADR+1 MADR=MADR+NX1*NX2*NX3 IF(MADR.GE.L) GO TO 99 CALL READV(LUN,NX1,NX2,NX3,IPAR(LX1),IPAR(LX2),IPAR(LX3), * RPAR(JADR4),POWERW) C C Computing B-spline under tension expansion coefficients: IF(NVAR.LE.0) THEN C No independent variable: CONTINUE ELSE C Size of the temporary storage location N=3*MAX0(NX1,NX2,NX3) JADR5=MADR+1 MADR=MADR+5*NX1 IF(MADR+N.GT.MAXADR) GO TO 99 C IERR enables to check for the proper function of subroutines C called IERR=1 IF(NVAR.EQ.1) THEN C One independent variable: C Two alternatives: Hermite or B-spline representations C may be used for the 1-D interpolation. Just one of the C following two statements must be supplied by '*' in the C first column: C First statement - Hermite representation: * CALL CURVN1(NX1,RPAR(JADR1),RPAR(JADR4), * * RPAR(JADR5),RPAR(MADR+1),SIGMA,IERR) C Second statement - B-spline representation: CALL CURVB1(NX1,RPAR(JADR1),RPAR(JADR4),RPAR(JADR4), * RPAR(JADR5),RPAR(MADR+1),SIGMA,IERR) C Do not forget to supply '*' into the first column of the C corresponding statement in subroutine VAL2. ELSE JADR6=MADR+1 MADR=MADR+5*NX2 IF(MADR+N.GT.MAXADR) GO TO 99 IF(NVAR.EQ.2) THEN C Two independent variables: CALL SURFB1(NX1,NX2,RPAR(JADR1),RPAR(JADR2), * RPAR(JADR4),NX1,RPAR(JADR4), * RPAR(JADR5),RPAR(JADR6),RPAR(MADR+1),SIGMA,IERR) ELSE C Three independent variables: JADR7=MADR+1 MADR=MADR+5*NX3 IF(MADR+N.GT.MAXADR) GO TO 99 CALL VAL3B1(NX1,NX2,NX3,RPAR(JADR1),RPAR(JADR2), * RPAR(JADR3),RPAR(JADR4),NX1,NX2,RPAR(JADR4), * RPAR(JADR5),RPAR(JADR6),RPAR(JADR7), * RPAR(MADR+1),SIGMA,IERR) END IF END IF IF(IERR.NE.0) THEN C 353 CALL ERROR('353 in VAL1: Strange error') C This error in the input functions should not appear. C Contact the authors. END IF END IF C Coefficients are evaluated C MFUNCT=MFUNCT+1 IPAR(MFUNCT)=MADR 80 CONTINUE GROUP=1. READ(LUN,*) TEXT,GROUP C End of loop for functions C C The remaining functions of the current group are not defined by C the input data: 81 CONTINUE DO 82 I=IFUNCT,NFUNCT MFUNCT=MFUNCT+1 IPAR(MFUNCT)=MADR 82 CONTINUE 90 CONTINUE C End of loop for groups of functions C IF(TEXT.NE.'END') THEN C 354 CALL ERROR('354 in VAL1: Input functions not properly ended') C Read in input data describing functions are not properly ended. END IF C C Movement in the memory: KADR=MAXADR-MADR DO 91 I=MAXADR+1,NPAR IPAR(I-KADR)=IPAR(I) 91 CONTINUE DO 92 I=MFUNCT+1,IPAR(IPAR(IPAR(0))) IPAR(I)=IPAR(I)-KADR 92 CONTINUE RETURN C 99 CONTINUE C 355 CALL ERROR('355 in VAL1: Insufficient memory in /VALC/') C Insufficient memory for the input data in common block /VALC/. C The dimension NPAR of array IPAR (or RPAR) must be enlarged. C See the block data subroutine VALB. END C C----------------------------------------------------------------------- C C C SUBROUTINE SORTV(NX,X1,X2,IX) INTEGER NX,IX(NX) REAL X1(NX),X2(NX) C C This subroutine is an auxiliary routine to VAL1. It reorders the C input grid coordinates to be ascending. C C Auxiliary storage locations INTEGER I,J C DO 3 J=1,NX IX(J)=1 DO 1 I=1,J-1 IF(X1(J).EQ.X1(I)) GO TO 9 IF(X1(J).GT.X1(I)) IX(J)=IX(J)+1 1 CONTINUE DO 2 I=J+1,NX IF(X1(J).EQ.X1(I)) GO TO 9 IF(X1(J).GT.X1(I)) IX(J)=IX(J)+1 2 CONTINUE 3 CONTINUE DO 4 J=1,NX X2(IX(J))=X1(J) 4 CONTINUE RETURN C 9 CONTINUE C 356 CALL ERROR('356 in SORTV in VAL1: Identical grid coordinates') C Two identical grid coordinates encountered in the input data. END C C----------------------------------------------------------------------- C C C SUBROUTINE READV(LUN,NX1,NX2,NX3,IX1,IX2,IX3,VAL,POWERW) INTEGER LUN,NX1,NX2,NX3,IX1(NX1),IX2(NX2),IX3(NX3) REAL VAL(NX1,NX2,NX3),POWERW C C This subroutine is an auxiliary routine to VAL1. It reads from the C input data the values given at grid points. C C Auxiliary storage locations INTEGER I1,I2,I3 REAL AUX1 C READ(LUN,*) (((VAL(IX1(I1),IX2(I2),IX3(I3)),I1=1,NX1), * I2=1,NX2),I3=1,NX3) IF(POWERW.NE.1.) THEN AUX1=1./POWERW DO 3 I3=1,NX3 DO 2 I2=1,NX2 DO 1 I1=1,NX1 VAL(IX1(I1),IX2(I2),IX3(I3))= * VAL(IX1(I1),IX2(I2),IX3(I3))**AUX1 1 CONTINUE 2 CONTINUE 3 CONTINUE END IF C RETURN END C C======================================================================= C C C SUBROUTINE VAL2(ICLASS,IGROUP,NFUNCT,COOR,F,POWER) INTEGER ICLASS,IGROUP,NFUNCT REAL COOR(3),F(10,NFUNCT),POWER(NFUNCT) C C This subroutine evaluates the function value, the three first partial C derivatives and the six second partial derivatives of a given function C at a given point. C C Input: C ICLASS..Index of the class of the required functions. The classes C are indexed by integers starting from 1. C IGROUP..Index of the group of the required functions. The groups C of each class are indexed by integers starting from 1. C NFUNCT..Number of the required functions. All functions belonging C to the IGROUP-th group of the ICLASS-th class and defined C by the input data must be required. The functions defined C by the input data (see subroutine VAL1) are one-to-one C corresponding to the integers which identify what the C function describes. The position of each evaluated C function in the output array F (see below) is determined C by this integer. That is why NFUNCT must be greater than C or equal to the greatest of these integers. The required C functions not defined by the input data are defined on the C output of this subroutine and are zero. C COOR... Array containing coordinates X1, X2, X3 of the given point C None of the input parameters are altered. C C Output: C F... Array containing, in each its column, function value, the C first and second partial derivatives of the corresponding C evaluated function in the order F, F1, F2, F3, F11, F12, C F22, F13, F23, F33. C POWER...The specified function is equal to the POWER-th power of C the corresponding physical quantity. The zero value of C the POWER indicates that the corresponding function is not C defined by the input data. C C Common block: INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: * EXTERNAL CURV2D EXTERNAL CURVBD EXTERNAL SURFBD,VAL3BD C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1995, March 28 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C The evaluated function has the form of C F(X1,X2,X3) = W(A1,A2,A3) - B1 - B2 - B3 , C C Its first derivatives are C dF dW dAk dB1 dB2 dB3 C --- = --- * --- - --- - --- - --- , C dXi dAk dXi dXi dXi dXi C C Its second derivatives are C d2 F d W d2 Ak d2 W dAk dAj d2 B1 d2 B3 C ------- = ---*------- + -------*---*--- - ------- - ... - -------. C dXi dXm dAk dXi dXm dAk dAj dXi dXm dXi dXm dXi dXm C C....................................................................... C INTEGER JGROUP,LFUNCT,MFUNCT,JFUNCT,LADR,MADR,IADR,IVAL INTEGER NVAR,IVAR(3),JVAR,KVAR INTEGER NX(3),NX1,NX2,NX3 EQUIVALENCE (NX(1),NX1),(NX(2),NX2),(NX(3),NX3) REAL XX(3),XX1,XX2,XX3 EQUIVALENCE (XX(1),XX1),(XX(2),XX2),(XX(3),XX3) CV3 REAL R1,R2,R3 INTEGER JADR(7),JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7 EQUIVALENCE (JADR(1),JADR1),(JADR(2),JADR2),(JADR(3),JADR3) EQUIVALENCE (JADR(4),JADR4),(JADR(5),JADR5),(JADR(6),JADR6) EQUIVALENCE (JADR(7),JADR7) REAL SIGMA,W(10),AUX1,AUX2 INTEGER I,J,K,M,N,ISYM(3,3) DATA ISYM/5,6,8,6,7,9,8,9,10/ C C JGROUP..Address of the IGROUP-th group of the ICLASS-th class. C LFUNCT,MFUNCT,JFUNCT... Addresses of the first, last and arbitrary C functions of the group. C LADR,MADR,IADR... Addresses of the first, last and arbitrary C parameters of the current function. C IVAL... Index of the function F being currently evaluated. C NVAR,IVAR(3),JVAR,KVAR... Number and types of the independent C variables A1, A2, A3 of the interpolated function W. C NX=(NX1,NX2,NX3)... Numbers of grid lines. C XX=(XX1,XX2,XX3),R1,R2,R3... Values of independent variables A1, C A2, A3 of function W. C JADR=(JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7)... Addresses of C parameters describing the interpolated function (grid C coordinates, B-spline coefficients, B-spline basis C functions). C SIGMA...Tension factor. C W... Array for the value, the first and second partial C derivatives of function W. C AUX1,AUX2,I,J,K,M,N... Local auxiliary variables. C ISYM... Storage of the symmetric 3*3 matrix. C C....................................................................... C C The default value of the function is the zero function. C Loop for the functions to be evaluated: DO 12 J=1,NFUNCT DO 11 I=1,10 F(I,J)=0. 11 CONTINUE POWER(J)=0. 12 CONTINUE *V CALL VAR1() C IF(ICLASS.LT.1.OR.IPAR(0).LT.ICLASS) THEN C 357 WRITE(*,'(2(A,I10))') ' CLASS=',ICLASS,', GROUP =',IGROUP CALL ERROR('357 in VAL2: Incorrect index of the class') C The index of the class of the functions to be evaluated is zero, C negative or greater than the number of classes defined. END IF JGROUP=IPAR(ICLASS-1)+IGROUP IF(IGROUP.LT.1.OR.IPAR(ICLASS).LT.JGROUP) THEN C 358 WRITE(*,'(2(A,I10))') ' CLASS=',ICLASS,', GROUP =',IGROUP CALL ERROR('358 in VAL2: Incorrect index of the group') C The index of the group of the functions to be evaluated is zero, C negative or greater than the number of groups defined within the C given class. END IF LFUNCT=IPAR(JGROUP-1)+1 MFUNCT=IPAR(JGROUP) MADR =IPAR(LFUNCT-1) C C Loop for functions F being evaluated: DO 90 JFUNCT=LFUNCT,MFUNCT C Starting and end addresses of the parameters describing the C function LADR=MADR+1 MADR=IPAR(JFUNCT) IF(LADR.LE.MADR) THEN C Index of function F being currently evaluated IVAL=IPAR(LADR) C Power of the corresponding physical quantity POWER(IVAL)=RPAR(LADR+1) C Tension factor SIGMA=RPAR(LADR+5) C C The number, types and values of the independent variables Ai C of function W being interpolated, and the functions Bi being C subtracted from the evaluated function: C Initial address IADR=LADR+6 C Initial number of the independent variables NVAR=0 JADR1=0 JADR2=0 JADR3=0 JADR4=0 C Loop for the possible independent variables: DO 20 M=LADR+2,LADR+4 C Type of the possible independent variable: J=IPAR(M) IF(J.NE.0) THEN IF(J.GT.0) THEN N=IABS(IPAR(IADR)) IF(N.GE.2) THEN NVAR=NVAR+1 NX(NVAR)=N IF(J.LE.3) THEN IVAR(NVAR)=J XX(NVAR)=COOR(J) ELSE K=IPAR(IPAR(LFUNCT+J-5)+1) IVAR(NVAR)=K+3 XX(NVAR)=F(1,K) END IF ELSE IF(N.EQ.1) THEN JADR(NVAR+1)=JADR(NVAR+1)+1 END IF IADR=IADR+1 ELSE C Subtracting certain functions from function F being C evaluated: IF(J.GE.-3) THEN C Subtracting a coordinate: F(1,IVAL)=F(1,IVAL)-COOR(-J) F(1-J,IVAL)=F(1-J,IVAL)-1. ELSE C Subtracting another function F: K=IPAR(IPAR(LFUNCT-J-5)) DO 19 I=1,10 F(I,IVAL)=F(I,IVAL)-F(I,K) 19 CONTINUE *V CALL VAR4(0,-1.) *V CALL VAR5(IVAL,K) END IF END IF END IF 20 CONTINUE C CV3 Lines denoted by 'CV3' in the first 3 columns are related to CV3 the kind of extrapolation outside the grid used in version 3 CV3 (January 1991) and older. In those versions, the first and CV3 second derivatives were incorrect outside the grid. CV3 If removing 'CV3' and 'CV3-V' from the executable statements, CV3 the kind of extrapolation from ver.3 is restored. Then, the CV3 first derivatives are correctly evaluated (unlike in ver.3), CV3 but the second derivatives are incorrect (as in ver.3). CV3 Similarly, variations of functional values are correct, and CV3 first variations of first derivatives are incorrect. CV3 C Interpolation of function W: JADR1=IADR+JADR1 CV3-V CALL VAR4(0,1.) IF(NVAR.LE.0) THEN C No independent variable: W(1)=RPAR(JADR1) *V CALL VAR2(1,1.,0.,0.,0.) *V CALL VAR3(JADR1-1) ELSE JADR2=JADR1+NX1+JADR2 CV3 R1=XX1 CV3 IF(XX1.LT.RPAR(JADR1)) THEN CV3 XX1=RPAR(JADR1) CV3 ELSE IF(XX1.GT.RPAR(JADR2-1)) THEN CV3 XX1=RPAR(JADR2-1) CV3 END IF CV3 R1=R1-XX1 IF(NVAR.EQ.1) THEN C One independent variable: JADR3=JADR2+NX1 C Two alternatives: Hermite or B-spline representations C may be used for the 1-D interpolation. Just one of the C following two statements must be supplied by '*' in the C first column: C First statement - Hermite representation: * CALL CURV2D(XX1,W(1),W(2),W(5),NX1, * * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3),SIGMA) C Second statement - B-spline representation: CALL CURVBD(XX1,W(1),W(2),W(5),NX1, * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3),SIGMA) C Do not forget to supply '*' into the first column of the C corresponding statement in subroutine VAL1. *V CALL VAR3(JADR2-1) ELSE JADR3=JADR2+NX2+JADR3 CV3 R2=XX2 CV3 IF(XX2.LT.RPAR(JADR2)) THEN CV3 XX2=RPAR(JADR2) CV3 ELSE IF(XX2.GT.RPAR(JADR3-1)) THEN CV3 XX2=RPAR(JADR3-1) CV3 END IF CV3 R2=R2-XX2 IF(NVAR.EQ.2) THEN C Two independent variables: JADR4=JADR3+NX1*NX2 JADR5=JADR4+5*NX1 CALL SURFBD(XX1,XX2,W(1),W(2),W(3),W(5),W(6),W(7), * NX1,NX2,RPAR(JADR1),RPAR(JADR2),RPAR(JADR3), * RPAR(JADR4),RPAR(JADR5),SIGMA) *V CALL VAR3(JADR3-1) ELSE C Three independent variables: JADR4=JADR3+NX3+JADR4 JADR5=JADR4+NX1*NX2*NX3 JADR6=JADR5+5*NX1 JADR7=JADR6+5*NX2 CV3 R3=XX3 CV3 IF(XX3.LT.RPAR(JADR3)) THEN CV3 XX3=RPAR(JADR3) CV3 ELSE IF(XX3.GT.RPAR(JADR4-1)) THEN CV3 XX3=RPAR(JADR4-1) CV3 END IF CV3 R3=R3-XX3 CALL VAL3BD(XX1,XX2,XX3,W(1),W(2),W(3),W(4),W(5),W(6), * W(7),W(9),W(10),W(8),NX1,NX2,NX3, * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3),RPAR(JADR4), * RPAR(JADR5),RPAR(JADR6),RPAR(JADR7),SIGMA) *V CALL VAR3(JADR4-1) CV3 W(1)=W(1)+W(4)*R3 CV3 IF(R1.EQ.0.) W(2)=W(2)+W(8)*R3 CV3 IF(R2.EQ.0.) W(3)=W(3)+W(9)*R3 CV3 IF(R3.EQ.0.) W(4)=W(4)+W(8)*R1+W(9)*R2 CV3-V CALL VAR4(13,R3) END IF CV3 W(1)=W(1)+W(3)*R2 CV3 IF(R1.EQ.0.) W(2)=W(2)+W(6)*R2 CV3 IF(R2.EQ.0.) W(3)=W(3)+W(6)*R1 CV3-V CALL VAR4(9,R2) END IF CV3 W(1)=W(1)+W(2)*R1 CV3-V CALL VAR4(5,R1) END IF CV3-V CALL VAR5(0,0) C Function W is evaluated C C Evaluation of function f: C Functional value (zero derivative) F(1,IVAL)=F(1,IVAL)+W(1) *V CALL VAR4(0,0.) *V CALL VAR4(1,1.) C Loop for the summation index K: DO 39 K=1,NVAR KVAR=IVAR(K) IF(KVAR.LE.3) THEN C First derivatives - first term on R.H.S. F(1+KVAR,IVAL)=F(1+KVAR,IVAL)+W(1+K) C Second derivatives - second term on R.H.S. (the first term C vanishes in this case) - loop for the summation index J: DO 32 J=1,NVAR JVAR=IVAR(J) IF(JVAR.LE.3) THEN IF(JVAR.LE.KVAR) THEN N=ISYM(JVAR,KVAR) F(N,IVAL)=F(N,IVAL)+W(ISYM(J,K)) END IF ELSE JVAR=JVAR-3 AUX1=W(ISYM(J,K)) DO 31 I=1,JVAR N=ISYM(I,JVAR) F(N,IVAL)=F(N,IVAL)+AUX1*F(1+I,JVAR) 31 CONTINUE END IF 32 CONTINUE *V CALL VAR4(4*K+1+KVAR,1.) ELSE KVAR=KVAR-3 DO 33 I=2,4 *V CALL VAR4(4*K+I,F(I,KVAR)) 33 CONTINUE END IF 39 CONTINUE *V CALL VAR5(IVAL,0) C Loop for the summation index K: DO 49 K=1,NVAR KVAR=IVAR(K) IF(KVAR.GT.3) THEN KVAR=KVAR-3 *V CALL VAR4(0,W(1+K)) C First and second derivatives - first terms on R.H.S. DO 44 I=2,10 F(I,IVAL)=F(I,IVAL)+W(1+K)*F(I,KVAR) 44 CONTINUE C Second derivatives - second term on R.H.S. - C loop for the summation index J: DO 48 J=1,NVAR JVAR=IVAR(J) IF(JVAR.LE.3) THEN AUX1=W(ISYM(J,K)) DO 45 I=1,KVAR N=ISYM(I,KVAR) F(N,IVAL)=F(N,IVAL)+AUX1*F(1+I,KVAR) 45 CONTINUE ELSE JVAR=JVAR-3 AUX1=W(ISYM(J,K)) DO 47 M=1,3 AUX2=AUX1*F(1+M,JVAR) DO 46 I=1,M N=ISYM(I,M) F(N,IVAL)=F(N,IVAL)+AUX2*F(1+I,KVAR) 46 CONTINUE *V CALL VAR4(1+M,AUX2) 47 CONTINUE END IF 48 CONTINUE *V CALL VAR5(IVAL,KVAR) END IF 49 CONTINUE C END IF 90 CONTINUE C End of loop for evaluated functions F C RETURN END C C======================================================================= Cval.inc 0100666 0000765 0000765 00000017622 06767630510 011730 0 ustar bulant bulant CC INCLUDE 'val.inc' C ------------------------------------------------------------------ INTEGER NPAR PARAMETER (NPAR=500000) INTEGER IPAR(0:NPAR) REAL RPAR(0:NPAR) EQUIVALENCE (IPAR,RPAR) COMMON/VALC/IPAR SAVE /VALC/ C ------------------------------------------------------------------ C Common block /VALC/ is included in subroutines VAL1 and VAL2. C The parameters are stored sequentially in one array regardless of C the fact whether they are of type INTEGER or REAL. The individual C numeric storage units of the array are indexed starting from 0 and C are named IPAR(I) or RPAR(I) depending on the type of a parameter. C The index of the last allocated numeric storage unit is NPAR (see C (f) below). If NPAR is changed (see the third statement of the C above block data subroutine VALB), it must be adjusted in C subroutines VAL1 and VAL2, too. C C Common block /VALC/ can be divided into two parts. The first part C (see (a)-(d) below) of the common block /VALC/ contains integers. C The number of these integers in the first part equals to C 1+MCLASS+NG+NF, where MCLASS is the total number of classes, NG is C the total number of all groups of all classes, NF is the total C number of all functions of all groups of all classes. The first C part of the common block specifies the division of the common C block /VALC/ into parameters describing individual functions. C The second part (see (e) below) of the common block /VALC/ C contains the parameters describing individual functions, stored C successively for the first, second, ..., last function of the c first group of the first class, for the first, second, ..., last c function of the second group of the first class, ..., for the c first, second, ..., last function of the first group of the second c class, ..., for the first, second, ..., last function of the last C group of the last class. The second part of the common block C /VALC/ contains both integer and real parameters. C For an example refer to the sample input data for the model. C C (a) Numeric storage unit IPAR(0) contains the number MCLASS of C classes. C C (b) Classes: C Subsequent numeric storage units (IPAR(I),I=1,MCLASS) correspond C to the individual classes. One numeric storage unit corresponds C to one class. The numeric storage unit corresponding to a class C contains the index of the numeric storage unit corresponding to C the last group of the class. C C (c) Groups: C Subsequent numeric storage units (IPAR(I),I=MCLASS+1,MCLASS+NG) C correspond to the individual groups. The total number of these C storage units is NG. One numeric storage unit corresponds to one C group. The numeric storage unit corresponding to a group contains C the index of the numeric storage unit corresponding to the last C function of the group. C C (d) Functions: C Subsequent numeric storage units (IPAR(I),I=MCLASS+NG+1, C MCLASS+NG+NF) correspond to the individual functions. The total C number of these storage units is NF. One numeric storage unit C corresponds to one function. The numeric storage unit C corresponding to a function contains the index of the numeric C storage unit corresponding to the last parameter that describes C the function. The functions are stored in the order in which they C have been specified by the input data. Since the number of C functions in the input data corresponding to one group may be less C than their maximum number NFUNCT (input parameter of subroutine C VAL1), some numeric storage units relevant to functions may not C correspond to the functions specified by the input data. Each C such numeric storage unit contains the same address as the C previous numeric storage unit (i.e. the corresponding function is C specified by no parameter) and has no influence on the function C evaluation. C C (e) Parameters of functions: C Subsequent numeric storage units (IPAR(I),I=MCLASS+NG+NF+1, C MCLASS+NG+NF+NP) contain the parameters describing individual C functions. Here we have denoted by NP the total number of these C storage units. Any number of numeric storage units may correspond C to the parameters of one function. The first numeric storage unit C corresponding to a function contains the integer that identifies C the physical meaning of the function, e.g. its values may C identify P-wave velocity, S-wave velocity, density, etc. The C second numeric storage unit contains the power of the physical C quantity, see 'Input data for one function' (1). If item (1) of C 'Input data for one function' is omitted, the two first numeric C storage units corresponding to the parameters of the function C contain 1 (the first INTEGER, the second REAL). The subsequent C numeric storage units contain 'Input data for one function' (2), C (3), (4), (5) and (6), stored in the same amount as read from the C input data. Data (4), (5), (6) and (7) are reordered to render C the grid coordinates in ascending order. Instead of the grid C values (7), the coefficients describing the function in terms of a C B-spline under tension basis are stored (only if subroutine CURVN1 C (Hermite representation) is used, the grid values (7) are stored). C These parameters are followed by arrays of length 5*NX(1), ..., C 5*NX(NVAR) respectively, containing the B-spline under tension C basis data computed for the projections of the grid onto the axes C of individual independent variables (only if subroutine CURVN1 C (Hermite representation) is used, the first NX(1) numeric storage C units contain the second derivatives and the following 4*NX(1) C numeric storage units are undefined. C C (f) Undefined part of the common block: C Subsequent numeric storage units (IPAR(I),I=MCLASS+NG+NF+NP+1, C NPAR) are undefined. C C Memory model of the common block /VALC/: C ------------------------------------------------------------------ C Address: 0 JCLASS-1 JCLASS JGROUP-1 JGROUP JFUNCT-1 JFUNCT C Value: MCLASS LGROUP-1 MGROUP LFUNCT-1 MFUNCT LADR-1 MADR C .................................................................. C For the meaning of individual items in this table see below. C ------------------------------------------------------------------ C The way of access to IFUNCT-th function of IGROUP-th group of the C ICLASS-th class: C Address of last class..................... MCLASS=IPAR(0) C Address of ICLASS-th class................ JCLASS=ICLASS C (It must be: 1.LE.JCLASS.LE.MCLASS) C Address of first group of the class....... LGROUP=IPAR(JCLASS-1)+1 C Address of last group of the class........ MGROUP=IPAR(JCLASS) C Address of IGROUP-th group of the class... JGROUP=LGROUP-1+IGROUP C (it must be: LGROUP.LE.JGROUP.LE.MGROUP) C Address of first function of the group.... LFUNCT=IPAR(JGROUP-1)+1 C Address of last function of the group..... MFUNCT=IPAR(JGROUP) C Address of IFUNCT-th function of the group JFUNCT=LFUNCT-1+IFUNCT C (it must be: LFUNCT.LE.JFUNCT.LE.MFUNCT) C Address of first function parameter....... LADR=IPAR(JFUNCT-1)+1 C Address of last function parameter........ MADR=IPAR(JFUNCT) C The parameters of the function are stored in IPAR(LADR) to C IPAR(MADR). C C Common block /VALC/ is included in FORTRAN 77 source code file C 'val.for', and also in source code files 'invsoft.for' and C 'invtt.for' of package CRT. C C Date: 1999, September 15 C Coded by Ludek Klimes C C======================================================================= Cvalv.for 0100666 0000765 0000765 00000127674 07041770506 012140 0 ustar bulant bulant CC Subroutine file 'val.for' for function specification and interpolation C - designed to perform the interpolation of a set of functions in a C rectangular grid. C C Date: 1999, September 15 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutines: C VALB... Block data subroutine initiating common block /VALC/ to C store the data describing the interpolated functions. C VALB C VAL1... Subroutine designed to read the input data for the C functions, to compute the coefficients of the expansion C and to store them in the memory. C VAL1 C SORTV...Auxiliary subroutine to subroutine VAL1. C SORTV C READV...Auxiliary subroutine to subroutine VAL1. C READV C VAL2... Subroutine evaluating the functions including their first C and second derivatives. The functions may be used to C specify various surfaces in the model, the space C distributions of various parameters, e.t.c. The functions C are represented as a tensor product of splines under C tension of at most 3 independent variables (i.e. a linear C combination of products of B-splines under tension of at C most 3 independent variables). Outside the specified C rectangular grid, the functions are extrapolated by their C analytic continuation. See lines of subroutine VAL2 with C 'CV3' in first 3 columns for comparison with the kind of C extrapolation used in old versions (outside the specified C rectangular grid, the functions were linear along straight C lines perpendicular to the boundary of the grid). The C functions may be embedded: the independent variable of C the function may be another function of the same group C (see below) foregoing in the input data. C VAL2 C Subroutines of this file employ routines CURVN1 (or its alternative C CURVB1), CURV2D (or its alternative CURVBD), SURFB1, SURFBD, VAL3B1, C VAL3BD, VGEN, TERMS, SNHCSH, TRIDEC, TRISOL, DSPLNZ, INTRVL from the C subroutine package 'FITPACK' by Alan Kaylor Cline, Department of C Computer Sciences, University of Texas at Austin. C C Note: C The lines denoted by '*V' in the first two columns of file C 'val.for' in subroutine VAL2 are designed to calculate the model C variations with respect to the model parameters. C File 'valv.for', intended for the model inversion, is created C from 'val.for' by replacing each '*V' in the first two columns C by spaces using program 'clean.for'. Subroutines VAR4 and VAR5 C of file 'var.for' may then be called to handle the variations. C C....................................................................... C C Classes of functions: C The interpolated functions are divided into some classes, e.g., C functions describing interfaces, functions describing the medium C parameters, functions describing the properties of the source, C etc. The number MCLASS of the defined classes is stored in the C memory and is initially zero. The new class may be defined by C means of the invocation of subroutine VAL1, see its input argument C ICLASS. During one invocation of VAL1, only the groups of C functions relevant to one class may be defined. Subroutine VAL1 C may be called several times even for one class to define its C groups successively, stage by stage. In this case, the input data C for the groups of functions relevant to one class may be read in C from various files. C C Groups of functions: C The interpolated functions of each class are divided into some C groups. For instance, the class of functions describing the medium C parameters is divided into groups corresponding to individual C complex blocks. The individual groups need not contain the same C number of functions. The group corresponding to a complex block C may contain e.g. the functions describing P-wave velocity, S-wave C velocity, density, etc. The functions not specified by the input C data but required by the program are defined and are zero. C C C Input data (read in by subroutine VAL1): C These input data define the groups of functions from the specified C class. The index ICLASS of the class is an input argument of C subroutine VAL1. If the class is not defined by a previous C invocation of VAL1, it is created. The number NGROUP of the C groups to be defined is an input argument of subroutine VAL1. The C data are read in by the list directed input (free format). C (1) NGROUP-times (i.e. once for each group of functions) input data C (1A)+(1B): C (1A) TEXTG,IGROUP C Identification of the group. C TEXTG...Any string. Its first 3 characters must differ from 'END' C and from any string identifying a physical quantity, C defined by input array TFUNCT of subroutine VAL1 (see C below). C IGROUP..Sequential number of the group in the class. C (1B) Several times Input data for one function, C see below. C If input array TFUNCT of subroutine VAL1 is fully filled by C spaces, 'Input data for one function' must be included C just NFUNCT-times (NFUNCT is an input argument of C subroutine VAL1). In this case, the input functions are C not identified by a string (see (1) of 'Input data for one C function'), their number and order must be a priori known. C This is, for instance, the case of smooth surfaces: each C group corresponds to one surface and contains just one C function. The index of the surface coincides with the C index of the group, and no identification and sorting of C functions inside a group is needed. C If input array TFUNCT of subroutine VAL1 is not fully filled by C spaces, 'Input data for one function' may be included C N-times, where 0.LE.N.LE.NFUNCT. In this case, the input C functions of individual groups are identified by a string C (see (1) of 'Input data for one function') in the input C data, their number and order may be arbitrary (note that C their number must be less than or equal to NFUNCT). This C is, for instance, the case of complex blocks: each group C corresponds to one complex block and contains some number C of functions describing material parameters. Individual C functions (material parameters) are identified by a string C in the input data. C (2) TEXTE,AUX C End of data. C TEXTE...String, the first 3 characters of which must be upper-case C 'END'. C AUX... Any number or a slash. C C C Input data for one function: C The data are read in by the list directed input (free format). In C the list of input data below, each numbered paragraph indicates C the beginning of a new input operation (new READ statement). If C the first letter of the symbolic name of the input variable is C I-N, the corresponding value in input data must be of the type C INTEGER. Otherwise (except TEXTF), the input parameter is of the C type REAL. C (1) TEXTF,POWER C Physical meaning of the function. This input is not performed if C input character array TFUNCT of subroutine VAL1 (see below) is C fully filled by spaces. C TEXTF...String identifying which physical quantity the function C describes. Only the first 3 characters are significant. C The first 3 characters of the string must not be equal to C 'END'. The set of meaningful strings is defined by input C array TFUNCT of subroutine VAL1 (see below). C POWER...The specified function is equal to the POWER-th power of C the physical quantity. C Default: POWER=1. C (2) IVAR1,IVAR2,IVAR3,SIGMA,POWERW,/ C The form of the function. C IVAR1,IVAR2,IVAR3... Denote the form of the function. The function C must be of the form C F(X1,X2,X3) =W(A1,A2,A3)-B1-B2-B3 . C X1, X2, X3 are the general coordinates. Each of A1, A2, C A3, B1, B2, B3 must be either: (a) one of general C coordinates X1, X2, X3, (b) another previously defined C function F(X1,X2,X3) of the same group, or (c) must be C left out. At most 3 of parameters A1-B3 may be of kind C (a) or (b). Note that IVAR1 controls the type of A1 and C B1, IVAR2 controls the type of A2 and B2, IVAR3 controls C the type of A3 and B3. C For IVAR1.EQ.0: A1, B1 are empty (left out), C for IVAR1.EQ.1: A1=X1, B1 is empty, C for IVAR1.EQ.2: A1=X2, B1 is empty, C for IVAR1.EQ.3: A1=X3, B1 is empty, C for IVAR1.GE.4: A1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same group defined in the input C data as the (IVAR1-3)-th function of the group. B1 is C empty, C for IVAR1.EQ.-1: B1=X1, A1 is empty, C for IVAR1.EQ.-2: B1=X2, A1 is empty, C for IVAR1.EQ.-3: B1=X3, A1 is empty, C for IVAR1.LE.-4: B1=F(X1,X2,X3), where F(X1,X2,X3) is C another function of the same group defined in the input C data as the (-IVAR1-3)-th function of the group. A1 is C empty. C The meaning of the parameters IVAR2, IVAR3 is similar. C Examples: C IVAR1: IVAR2: IVAR3: the form of the function: C 1 2 3 F(X1,X2,X3)=W(X1,X2,X3) C 3 1 2 F(X1,X2,X3)=W(X3,X1,X2) C 1 2 0 F(X1,X2,X3)=W(X1,X2) C 1 2 -3 F(X1,X2,X3)=W(X1,X2)-X3 C 1 -3 2 F(X1,X2,X3)=W(X1,X2)-X3 C 5 0 0 F(X1,X2,X3)=W(F2(X1,X2,X3)), where C F2(X1,X2,X3) is the second function of the group defined C in the input data. Function W is interpolated by means of C splines under tension. C SIGMA...Is the tension factor (its sign is ignored). This value C indicates the curviness desired. If ABS(SIGMA) is nearly C zero (e.g. 0.001), the resulting surface is approximately C the tensor product of cubic splines. If ABS(SIGMA) is C large (e.g. 50.), the resulting surface is approximately C tri-linear. If SIGMA equals zero, tensor products of C cubic splines result. A recommended value for SIGMA is C approximately 1. In absolute value. C POWERW..Given grid values (7) correspond to the POWERW-th power of C interpolated function W. The given grid values (7) are C thus raised to the (1/POWERW)-th power immediately after C reading and then interpolated. C /... Obligatory slash at the end of line for future extensions. C Default: IVAR1=0, IVAR2=0, IVAR3=0, SIGMA=0, POWERW=1. C (3) NX(1),...,NX(NVAR) C The numbers of grid coordinates for the interpolation. C This input is performed if at least one of IVAR1, IVAR2, IVAR3 is C positive. C Each of NX(1),...,NX(NVAR) corresponds to one positive value of C IVAR1, IVAR2, IVAR3 and specifies the number of grid coordinates C corresponding to that independent variable of function W, see (2). C The sign of NX(1),...,NX(NVAR) is ignored. NVAR (.LE.3) is the C number of positive values of the above quantities IVAR1, IVAR2, C IVAR3, i.e. the number of independent variables of function W, C see (2). C (4) X1(1),...,X1(NX(1)) C The grid coordinates corresponding to the first independent C variable of function W, see (2). C This input is performed if NX(1) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (5) X2(1),...,X2(NX(2)) C The grid coordinates corresponding to the second independent C variable of function W, see (2). C This input is performed if NX(2) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (6) X3(1),...,X3(NX(3)) C The grid coordinates corresponding to the third independent C variable of function W, see (2). C This input is performed if NX(3) is specified, see (3), and is not C zero. The grid coordinates may be specified in any order. C (7) (((W(I,J,K),I=1,MAX(NX(1),1)),J=1,MAX(NX(2),1)),K=1,MAX(NX(3),1)) C The values of the POWERW-th power of function W at grid points. C Function value W(I,J,K) corresponds to point (X1(I),X2(J),X3(K)). C C======================================================================= C C C C Storage in the memory: C The parameters describing the interpolated functions are stored C in common block /VALC/ initialized in the following subroutine: C ------------------------------------------------------------------ BLOCK DATA VALB INCLUDE 'val.inc' C val.inc DATA IPAR(0)/0/ END C ------------------------------------------------------------------ C C======================================================================= C C C SUBROUTINE VAL1(LUN,ICLASS,NGROUP,NFUNCT,TFUNCT) INTEGER LUN,ICLASS,NGROUP,NFUNCT CHARACTER*(*) TFUNCT(NFUNCT) C C This subroutine reads the input data for a set of functions, C determines the parameters necessary to compute an interpolatory C function on a three-dimensional rectangular grid, and stores them in C the memory. The function determined can be represented as a tensor C product of splines under tension of at most 3 independent variables C (i.e. a linear combination of products of B-splines under tension of C at most 3 independent variables). The functions may be embedded: the C independent variable of the function may be another function of the C same group foregoing in the input data. For actual mapping of points C it is necessary to call the subroutine VAL2, which also returns the C first and second partial derivatives. Subroutine VAL1 may be called C several times. The groups in the class are indexed successively, C following the groups of the class defined during the previous C invocations. C C Input: C LUN... Logical unit number of the external input device C containing the input data. C ICLASS..Index of the class of the functions to be specified. The C classes are indexed by integers starting from 1. C NGROUP..Number of groups of functions to be specified during the C current invocation of VAL1. The groups of each class are C indexed by integers starting from 1. If some groups of C functions of the ICLASS-th class were specified in the C previous invocation of VAL1, the groups of functions now C read in are appended to them and are indexed following C them. C NFUNCT..Maximum number of functions to be specified for each C group. The actual number of specified functions may be C different for different groups. However, it must be less C than or equal to NFUNCT. C TFUNCT..Strings identifying the functions specified in the input C data. The function identified in the input data by string C TFUNCT(I) is associated with integer I. This integer C identifies what the function describes. C None of the input parameters are altered. C C No output. C C Common block: INCLUDE 'val.inc' C val.inc C All the storage locations of the common block are defined in this C subroutine. C C Subroutines and external functions required: * EXTERNAL CURVN1 EXTERNAL CURVB1 EXTERNAL VALB,SURFB1,VAL3B1,SORTV,READV C VALB... Block data subroutine of this file. C CURVN1 or CURVB1 (alternatives), SURFB1, VAL3B1, SNHCSH, VGEN, C TERMS, TRIDEC, TRISOL... Subroutine package 'FITPACK' C (file 'fit.for'). C SORTV, READV... This file. C C Date: 1999, September 15 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C LOGICAL WHAT INTEGER MCLASS,MGROUP,MFUNCT,LADR,MADR,MAXADR INTEGER KCLASS,KGROUP,KFUNCT,KADR,NVAR CHARACTER*3 TEXT REAL GROUP,SIGMA,POWERW INTEGER LX(3),LX1,LX2,LX3 EQUIVALENCE (LX(1),LX1),(LX(2),LX2),(LX(3),LX3) INTEGER NX(3),NX1,NX2,NX3 EQUIVALENCE (NX(1),NX1),(NX(2),NX2),(NX(3),NX3) INTEGER JADR(7),JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7 EQUIVALENCE (JADR(1),JADR1),(JADR(2),JADR2),(JADR(3),JADR3) EQUIVALENCE (JADR(4),JADR4),(JADR(5),JADR5),(JADR(6),JADR6) EQUIVALENCE (JADR(7),JADR7) INTEGER IGROUP,IFUNCT,IERR,I,J,L,N C C WHAT... Flag if the physical meaning of the functions is included C in the input data. C MCLASS,MGROUP,MFUNCT,LADR,MADR,MAXADR... Positions in the memory. C KCLASS,KGROUP,KFUNCT,KADR... Shifts in the memory. C NVAR... Number of the independent variables A1, A2, A3 of the C interpolated function W. C TEXT... String identifying the current group or the current C function. C GROUP...Index of the current group or power of the physical C quantity. C SIGMA...Tension factor. C POWERW..Given grid values (7) are raised to the (1/POWERW)-th C power immediately after reading and then interpolated. C LX=(LX1,LX2,LX3)... Addresses of auxiliary storage locations for C reordering the grid coordinates. C NX=(NX1,NX2,NX3)... Numbers of grid lines. C JADR=(JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7)... Addresses of C parameters describing the interpolated function (grid C coordinates, B-spline coefficients, B-spline basis C functions). C IGROUP,IFUNCT... Do loop variables. C IERR... Local variable to check the proper function of called C subroutines. C I,J,L,N... Local auxiliary variables. C C....................................................................... C C Flag if the physical meaning of the functions is included in the C input data: WHAT=.FALSE. DO 10 I=1,NFUNCT IF(TFUNCT(I).NE.' ') WHAT=.TRUE. 10 CONTINUE C C Positions in the memory: IF(ICLASS.GT.IPAR(0)) THEN C New class: MCLASS=IPAR(0) KCLASS=ICLASS-MCLASS ELSE C Old class: MCLASS=ICLASS KCLASS=0 END IF MGROUP=IPAR(MCLASS) KGROUP=KCLASS+NGROUP MFUNCT=IPAR(MGROUP) KFUNCT=KGROUP+NGROUP*NFUNCT MADR=IPAR(MFUNCT) KADR=NPAR-IPAR(IPAR(IPAR(IPAR(0)))) IF(KADR.LT.KFUNCT) GO TO 99 C Upper bound of the available memory MAXADR=MADR+KADR C C Movement in the memory: DO 11 I=IPAR(IPAR(IPAR(IPAR(0)))),MADR+1,-1 IPAR(I+KADR)=IPAR(I) 11 CONTINUE DO 12 I=MADR,IPAR(IPAR(IPAR(0)))+1,-1 IPAR(I+KFUNCT)=IPAR(I) 12 CONTINUE DO 13 I=IPAR(IPAR(IPAR(0))),MFUNCT+1,-1 IPAR(I+KFUNCT)=IPAR(I)+KADR 13 CONTINUE MADR=MADR+KFUNCT DO 14 I=MFUNCT,MGROUP+1,-1 IPAR(I+KGROUP)=IPAR(I)+KFUNCT 14 CONTINUE MFUNCT=MFUNCT+KGROUP DO 15 I=MGROUP,MCLASS+1,-1 IPAR(I+KCLASS)=IPAR(I)+KGROUP 15 CONTINUE MGROUP=MGROUP+KCLASS DO 16 I=0,MCLASS IPAR(I)=IPAR(I)+KCLASS 16 CONTINUE C New classes: DO 17 I=MCLASS+1,ICLASS IPAR(I)=IPAR(MCLASS) 17 CONTINUE C Number of previously stored groups of functions of the class IGROUP=IPAR(ICLASS)-IPAR(ICLASS-1) IPAR(ICLASS)=IPAR(ICLASS)+NGROUP C New groups: DO 18 I=MGROUP+1,MGROUP+NGROUP IPAR(I)=IPAR(I-1)+NFUNCT 18 CONTINUE C C Loop for groups of functions: GROUP=1. READ(LUN,*) TEXT,GROUP DO 90 IGROUP=IGROUP+1,IGROUP+NGROUP IF(TEXT.EQ.'END') THEN C 351 CALL ERROR('351 in VAL1: End of input functions encountered') C End of input functions encountered before all NGROUP C groups of functions are defined in the input data. ELSE IF(INT(GROUP+0.5).NE.IGROUP) THEN C 352 CALL ERROR('352 in VAL1: Improper index of the group') C Improper index of the group of input functions in the C input data. END IF C Loop for functions of the current group: DO 80 IFUNCT=1,NFUNCT C Physical meaning of the function: IF(WHAT) THEN GROUP=1. READ(LUN,*) TEXT,GROUP DO 21 I=1,NFUNCT IF(TFUNCT(I).EQ.TEXT) THEN MADR=MADR+2 IF(MADR.GT.MAXADR) GO TO 99 IPAR(MADR-1)=I RPAR(MADR)=GROUP GO TO 22 END IF 21 CONTINUE GO TO 81 22 CONTINUE ELSE MADR=MADR+2 IF(MADR.GT.MAXADR) GO TO 99 IPAR(MADR-1)=IFUNCT RPAR(MADR)=1. END IF C C Form of the function: LADR=MADR+1 MADR=MADR+4 IF(MADR.GT.MAXADR) GO TO 99 IPAR(LADR) =0 IPAR(LADR+1)=0 IPAR(LADR+2)=0 RPAR(MADR) =0. POWERW =1. READ(LUN,*) * IPAR(LADR),IPAR(LADR+1),IPAR(LADR+2),RPAR(MADR),POWERW SIGMA=RPAR(MADR) IF(POWERW.EQ.0.) THEN C 359 CALL ERROR('359 in VAL1: Zero POWERW in input data') C Zero POWERW in input data describing B-spline interpolation C of functions used to specify surfaces or material parameters C in the model or initial line or surface source. C See input data for one function, C line (2). END IF C Number of independent variables: NVAR=0 DO 23 I=LADR,LADR+2 IF(IPAR(I).GT.0) NVAR=NVAR+1 23 CONTINUE C C Numbers of grid coordinates: LADR=MADR+1 MADR=MADR+NVAR IF(MADR.GT.MAXADR) GO TO 99 IF(LADR.LE.MADR) THEN READ(LUN,*) (IPAR(I),I=LADR,MADR) END IF C C Reading grid coordinates: L=MAXADR+1 NVAR=0 DO 24 J=LADR,MADR N=IABS(IPAR(J)) IF(N.GT.0) THEN LADR=MADR+1 MADR=MADR+N IF(N.EQ.1) THEN IF(MADR.GE.L-1) GO TO 99 READ(LUN,*) RPAR(LADR) ELSE L=L-N IF(MADR+N.GE.L-1) GO TO 99 NVAR=NVAR+1 NX(NVAR)=N LX(NVAR)=L JADR(NVAR)=LADR READ(LUN,*) (RPAR(I),I=MADR+1,MADR+N) CALL SORTV(N,RPAR(MADR+1),RPAR(LADR),IPAR(L)) END IF END IF 24 CONTINUE DO 25 I=NVAR+1,3 NX(I)=1 LX(I)=L-1 IPAR(L-1)=1 25 CONTINUE C C Reading grid values: JADR4=MADR+1 MADR=MADR+NX1*NX2*NX3 IF(MADR.GE.L) GO TO 99 CALL READV(LUN,NX1,NX2,NX3,IPAR(LX1),IPAR(LX2),IPAR(LX3), * RPAR(JADR4),POWERW) C C Computing B-spline under tension expansion coefficients: IF(NVAR.LE.0) THEN C No independent variable: CONTINUE ELSE C Size of the temporary storage location N=3*MAX0(NX1,NX2,NX3) JADR5=MADR+1 MADR=MADR+5*NX1 IF(MADR+N.GT.MAXADR) GO TO 99 C IERR enables to check for the proper function of subroutines C called IERR=1 IF(NVAR.EQ.1) THEN C One independent variable: C Two alternatives: Hermite or B-spline representations C may be used for the 1-D interpolation. Just one of the C following two statements must be supplied by '*' in the C first column: C First statement - Hermite representation: * CALL CURVN1(NX1,RPAR(JADR1),RPAR(JADR4), * * RPAR(JADR5),RPAR(MADR+1),SIGMA,IERR) C Second statement - B-spline representation: CALL CURVB1(NX1,RPAR(JADR1),RPAR(JADR4),RPAR(JADR4), * RPAR(JADR5),RPAR(MADR+1),SIGMA,IERR) C Do not forget to supply '*' into the first column of the C corresponding statement in subroutine VAL2. ELSE JADR6=MADR+1 MADR=MADR+5*NX2 IF(MADR+N.GT.MAXADR) GO TO 99 IF(NVAR.EQ.2) THEN C Two independent variables: CALL SURFB1(NX1,NX2,RPAR(JADR1),RPAR(JADR2), * RPAR(JADR4),NX1,RPAR(JADR4), * RPAR(JADR5),RPAR(JADR6),RPAR(MADR+1),SIGMA,IERR) ELSE C Three independent variables: JADR7=MADR+1 MADR=MADR+5*NX3 IF(MADR+N.GT.MAXADR) GO TO 99 CALL VAL3B1(NX1,NX2,NX3,RPAR(JADR1),RPAR(JADR2), * RPAR(JADR3),RPAR(JADR4),NX1,NX2,RPAR(JADR4), * RPAR(JADR5),RPAR(JADR6),RPAR(JADR7), * RPAR(MADR+1),SIGMA,IERR) END IF END IF IF(IERR.NE.0) THEN C 353 CALL ERROR('353 in VAL1: Strange error') C This error in the input functions should not appear. C Contact the authors. END IF END IF C Coefficients are evaluated C MFUNCT=MFUNCT+1 IPAR(MFUNCT)=MADR 80 CONTINUE GROUP=1. READ(LUN,*) TEXT,GROUP C End of loop for functions C C The remaining functions of the current group are not defined by C the input data: 81 CONTINUE DO 82 I=IFUNCT,NFUNCT MFUNCT=MFUNCT+1 IPAR(MFUNCT)=MADR 82 CONTINUE 90 CONTINUE C End of loop for groups of functions C IF(TEXT.NE.'END') THEN C 354 CALL ERROR('354 in VAL1: Input functions not properly ended') C Read in input data describing functions are not properly ended. END IF C C Movement in the memory: KADR=MAXADR-MADR DO 91 I=MAXADR+1,NPAR IPAR(I-KADR)=IPAR(I) 91 CONTINUE DO 92 I=MFUNCT+1,IPAR(IPAR(IPAR(0))) IPAR(I)=IPAR(I)-KADR 92 CONTINUE RETURN C 99 CONTINUE C 355 CALL ERROR('355 in VAL1: Insufficient memory in /VALC/') C Insufficient memory for the input data in common block /VALC/. C The dimension NPAR of array IPAR (or RPAR) must be enlarged. C See the block data subroutine VALB. END C C----------------------------------------------------------------------- C C C SUBROUTINE SORTV(NX,X1,X2,IX) INTEGER NX,IX(NX) REAL X1(NX),X2(NX) C C This subroutine is an auxiliary routine to VAL1. It reorders the C input grid coordinates to be ascending. C C Auxiliary storage locations INTEGER I,J C DO 3 J=1,NX IX(J)=1 DO 1 I=1,J-1 IF(X1(J).EQ.X1(I)) GO TO 9 IF(X1(J).GT.X1(I)) IX(J)=IX(J)+1 1 CONTINUE DO 2 I=J+1,NX IF(X1(J).EQ.X1(I)) GO TO 9 IF(X1(J).GT.X1(I)) IX(J)=IX(J)+1 2 CONTINUE 3 CONTINUE DO 4 J=1,NX X2(IX(J))=X1(J) 4 CONTINUE RETURN C 9 CONTINUE C 356 CALL ERROR('356 in SORTV in VAL1: Identical grid coordinates') C Two identical grid coordinates encountered in the input data. END C C----------------------------------------------------------------------- C C C SUBROUTINE READV(LUN,NX1,NX2,NX3,IX1,IX2,IX3,VAL,POWERW) INTEGER LUN,NX1,NX2,NX3,IX1(NX1),IX2(NX2),IX3(NX3) REAL VAL(NX1,NX2,NX3),POWERW C C This subroutine is an auxiliary routine to VAL1. It reads from the C input data the values given at grid points. C C Auxiliary storage locations INTEGER I1,I2,I3 REAL AUX1 C READ(LUN,*) (((VAL(IX1(I1),IX2(I2),IX3(I3)),I1=1,NX1), * I2=1,NX2),I3=1,NX3) IF(POWERW.NE.1.) THEN AUX1=1./POWERW DO 3 I3=1,NX3 DO 2 I2=1,NX2 DO 1 I1=1,NX1 VAL(IX1(I1),IX2(I2),IX3(I3))= * VAL(IX1(I1),IX2(I2),IX3(I3))**AUX1 1 CONTINUE 2 CONTINUE 3 CONTINUE END IF C RETURN END C C======================================================================= C C C SUBROUTINE VAL2(ICLASS,IGROUP,NFUNCT,COOR,F,POWER) INTEGER ICLASS,IGROUP,NFUNCT REAL COOR(3),F(10,NFUNCT),POWER(NFUNCT) C C This subroutine evaluates the function value, the three first partial C derivatives and the six second partial derivatives of a given function C at a given point. C C Input: C ICLASS..Index of the class of the required functions. The classes C are indexed by integers starting from 1. C IGROUP..Index of the group of the required functions. The groups C of each class are indexed by integers starting from 1. C NFUNCT..Number of the required functions. All functions belonging C to the IGROUP-th group of the ICLASS-th class and defined C by the input data must be required. The functions defined C by the input data (see subroutine VAL1) are one-to-one C corresponding to the integers which identify what the C function describes. The position of each evaluated C function in the output array F (see below) is determined C by this integer. That is why NFUNCT must be greater than C or equal to the greatest of these integers. The required C functions not defined by the input data are defined on the C output of this subroutine and are zero. C COOR... Array containing coordinates X1, X2, X3 of the given point C None of the input parameters are altered. C C Output: C F... Array containing, in each its column, function value, the C first and second partial derivatives of the corresponding C evaluated function in the order F, F1, F2, F3, F11, F12, C F22, F13, F23, F33. C POWER...The specified function is equal to the POWER-th power of C the corresponding physical quantity. The zero value of C the POWER indicates that the corresponding function is not C defined by the input data. C C Common block: INCLUDE 'val.inc' C val.inc C None of the storage locations of the common block are altered. C C Subroutines and external functions required: * EXTERNAL CURV2D EXTERNAL CURVBD EXTERNAL SURFBD,VAL3BD C CURV2D or CURVBD (alternatives), SURFBD, VAL3BD, SNHCSH, DSPLNZ, C INTRVL... Subroutine package 'FITPACK' (file 'fit.for'). C C Date: 1995, March 28 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C The evaluated function has the form of C F(X1,X2,X3) = W(A1,A2,A3) - B1 - B2 - B3 , C C Its first derivatives are C dF dW dAk dB1 dB2 dB3 C --- = --- * --- - --- - --- - --- , C dXi dAk dXi dXi dXi dXi C C Its second derivatives are C d2 F d W d2 Ak d2 W dAk dAj d2 B1 d2 B3 C ------- = ---*------- + -------*---*--- - ------- - ... - -------. C dXi dXm dAk dXi dXm dAk dAj dXi dXm dXi dXm dXi dXm C C....................................................................... C INTEGER JGROUP,LFUNCT,MFUNCT,JFUNCT,LADR,MADR,IADR,IVAL INTEGER NVAR,IVAR(3),JVAR,KVAR INTEGER NX(3),NX1,NX2,NX3 EQUIVALENCE (NX(1),NX1),(NX(2),NX2),(NX(3),NX3) REAL XX(3),XX1,XX2,XX3 EQUIVALENCE (XX(1),XX1),(XX(2),XX2),(XX(3),XX3) CV3 REAL R1,R2,R3 INTEGER JADR(7),JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7 EQUIVALENCE (JADR(1),JADR1),(JADR(2),JADR2),(JADR(3),JADR3) EQUIVALENCE (JADR(4),JADR4),(JADR(5),JADR5),(JADR(6),JADR6) EQUIVALENCE (JADR(7),JADR7) REAL SIGMA,W(10),AUX1,AUX2 INTEGER I,J,K,M,N,ISYM(3,3) DATA ISYM/5,6,8,6,7,9,8,9,10/ C C JGROUP..Address of the IGROUP-th group of the ICLASS-th class. C LFUNCT,MFUNCT,JFUNCT... Addresses of the first, last and arbitrary C functions of the group. C LADR,MADR,IADR... Addresses of the first, last and arbitrary C parameters of the current function. C IVAL... Index of the function F being currently evaluated. C NVAR,IVAR(3),JVAR,KVAR... Number and types of the independent C variables A1, A2, A3 of the interpolated function W. C NX=(NX1,NX2,NX3)... Numbers of grid lines. C XX=(XX1,XX2,XX3),R1,R2,R3... Values of independent variables A1, C A2, A3 of function W. C JADR=(JADR1,JADR2,JADR3,JADR4,JADR5,JADR6,JADR7)... Addresses of C parameters describing the interpolated function (grid C coordinates, B-spline coefficients, B-spline basis C functions). C SIGMA...Tension factor. C W... Array for the value, the first and second partial C derivatives of function W. C AUX1,AUX2,I,J,K,M,N... Local auxiliary variables. C ISYM... Storage of the symmetric 3*3 matrix. C C....................................................................... C C The default value of the function is the zero function. C Loop for the functions to be evaluated: DO 12 J=1,NFUNCT DO 11 I=1,10 F(I,J)=0. 11 CONTINUE POWER(J)=0. 12 CONTINUE CALL VAR1() C IF(ICLASS.LT.1.OR.IPAR(0).LT.ICLASS) THEN C 357 WRITE(*,'(2(A,I10))') ' CLASS=',ICLASS,', GROUP =',IGROUP CALL ERROR('357 in VAL2: Incorrect index of the class') C The index of the class of the functions to be evaluated is zero, C negative or greater than the number of classes defined. END IF JGROUP=IPAR(ICLASS-1)+IGROUP IF(IGROUP.LT.1.OR.IPAR(ICLASS).LT.JGROUP) THEN C 358 WRITE(*,'(2(A,I10))') ' CLASS=',ICLASS,', GROUP =',IGROUP CALL ERROR('358 in VAL2: Incorrect index of the group') C The index of the group of the functions to be evaluated is zero, C negative or greater than the number of groups defined within the C given class. END IF LFUNCT=IPAR(JGROUP-1)+1 MFUNCT=IPAR(JGROUP) MADR =IPAR(LFUNCT-1) C C Loop for functions F being evaluated: DO 90 JFUNCT=LFUNCT,MFUNCT C Starting and end addresses of the parameters describing the C function LADR=MADR+1 MADR=IPAR(JFUNCT) IF(LADR.LE.MADR) THEN C Index of function F being currently evaluated IVAL=IPAR(LADR) C Power of the corresponding physical quantity POWER(IVAL)=RPAR(LADR+1) C Tension factor SIGMA=RPAR(LADR+5) C C The number, types and values of the independent variables Ai C of function W being interpolated, and the functions Bi being C subtracted from the evaluated function: C Initial address IADR=LADR+6 C Initial number of the independent variables NVAR=0 JADR1=0 JADR2=0 JADR3=0 JADR4=0 C Loop for the possible independent variables: DO 20 M=LADR+2,LADR+4 C Type of the possible independent variable: J=IPAR(M) IF(J.NE.0) THEN IF(J.GT.0) THEN N=IABS(IPAR(IADR)) IF(N.GE.2) THEN NVAR=NVAR+1 NX(NVAR)=N IF(J.LE.3) THEN IVAR(NVAR)=J XX(NVAR)=COOR(J) ELSE K=IPAR(IPAR(LFUNCT+J-5)+1) IVAR(NVAR)=K+3 XX(NVAR)=F(1,K) END IF ELSE IF(N.EQ.1) THEN JADR(NVAR+1)=JADR(NVAR+1)+1 END IF IADR=IADR+1 ELSE C Subtracting certain functions from function F being C evaluated: IF(J.GE.-3) THEN C Subtracting a coordinate: F(1,IVAL)=F(1,IVAL)-COOR(-J) F(1-J,IVAL)=F(1-J,IVAL)-1. ELSE C Subtracting another function F: K=IPAR(IPAR(LFUNCT-J-5)) DO 19 I=1,10 F(I,IVAL)=F(I,IVAL)-F(I,K) 19 CONTINUE CALL VAR4(0,-1.) CALL VAR5(IVAL,K) END IF END IF END IF 20 CONTINUE C CV3 Lines denoted by 'CV3' in the first 3 columns are related to CV3 the kind of extrapolation outside the grid used in version 3 CV3 (January 1991) and older. In those versions, the first and CV3 second derivatives were incorrect outside the grid. CV3 If removing 'CV3' and 'CV3-V' from the executable statements, CV3 the kind of extrapolation from ver.3 is restored. Then, the CV3 first derivatives are correctly evaluated (unlike in ver.3), CV3 but the second derivatives are incorrect (as in ver.3). CV3 Similarly, variations of functional values are correct, and CV3 first variations of first derivatives are incorrect. CV3 C Interpolation of function W: JADR1=IADR+JADR1 CV3-V CALL VAR4(0,1.) IF(NVAR.LE.0) THEN C No independent variable: W(1)=RPAR(JADR1) CALL VAR2(1,1.,0.,0.,0.) CALL VAR3(JADR1-1) ELSE JADR2=JADR1+NX1+JADR2 CV3 R1=XX1 CV3 IF(XX1.LT.RPAR(JADR1)) THEN CV3 XX1=RPAR(JADR1) CV3 ELSE IF(XX1.GT.RPAR(JADR2-1)) THEN CV3 XX1=RPAR(JADR2-1) CV3 END IF CV3 R1=R1-XX1 IF(NVAR.EQ.1) THEN C One independent variable: JADR3=JADR2+NX1 C Two alternatives: Hermite or B-spline representations C may be used for the 1-D interpolation. Just one of the C following two statements must be supplied by '*' in the C first column: C First statement - Hermite representation: * CALL CURV2D(XX1,W(1),W(2),W(5),NX1, * * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3),SIGMA) C Second statement - B-spline representation: CALL CURVBD(XX1,W(1),W(2),W(5),NX1, * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3),SIGMA) C Do not forget to supply '*' into the first column of the C corresponding statement in subroutine VAL1. CALL VAR3(JADR2-1) ELSE JADR3=JADR2+NX2+JADR3 CV3 R2=XX2 CV3 IF(XX2.LT.RPAR(JADR2)) THEN CV3 XX2=RPAR(JADR2) CV3 ELSE IF(XX2.GT.RPAR(JADR3-1)) THEN CV3 XX2=RPAR(JADR3-1) CV3 END IF CV3 R2=R2-XX2 IF(NVAR.EQ.2) THEN C Two independent variables: JADR4=JADR3+NX1*NX2 JADR5=JADR4+5*NX1 CALL SURFBD(XX1,XX2,W(1),W(2),W(3),W(5),W(6),W(7), * NX1,NX2,RPAR(JADR1),RPAR(JADR2),RPAR(JADR3), * RPAR(JADR4),RPAR(JADR5),SIGMA) CALL VAR3(JADR3-1) ELSE C Three independent variables: JADR4=JADR3+NX3+JADR4 JADR5=JADR4+NX1*NX2*NX3 JADR6=JADR5+5*NX1 JADR7=JADR6+5*NX2 CV3 R3=XX3 CV3 IF(XX3.LT.RPAR(JADR3)) THEN CV3 XX3=RPAR(JADR3) CV3 ELSE IF(XX3.GT.RPAR(JADR4-1)) THEN CV3 XX3=RPAR(JADR4-1) CV3 END IF CV3 R3=R3-XX3 CALL VAL3BD(XX1,XX2,XX3,W(1),W(2),W(3),W(4),W(5),W(6), * W(7),W(9),W(10),W(8),NX1,NX2,NX3, * RPAR(JADR1),RPAR(JADR2),RPAR(JADR3),RPAR(JADR4), * RPAR(JADR5),RPAR(JADR6),RPAR(JADR7),SIGMA) CALL VAR3(JADR4-1) CV3 W(1)=W(1)+W(4)*R3 CV3 IF(R1.EQ.0.) W(2)=W(2)+W(8)*R3 CV3 IF(R2.EQ.0.) W(3)=W(3)+W(9)*R3 CV3 IF(R3.EQ.0.) W(4)=W(4)+W(8)*R1+W(9)*R2 CV3-V CALL VAR4(13,R3) END IF CV3 W(1)=W(1)+W(3)*R2 CV3 IF(R1.EQ.0.) W(2)=W(2)+W(6)*R2 CV3 IF(R2.EQ.0.) W(3)=W(3)+W(6)*R1 CV3-V CALL VAR4(9,R2) END IF CV3 W(1)=W(1)+W(2)*R1 CV3-V CALL VAR4(5,R1) END IF CV3-V CALL VAR5(0,0) C Function W is evaluated C C Evaluation of function f: C Functional value (zero derivative) F(1,IVAL)=F(1,IVAL)+W(1) CALL VAR4(0,0.) CALL VAR4(1,1.) C Loop for the summation index K: DO 39 K=1,NVAR KVAR=IVAR(K) IF(KVAR.LE.3) THEN C First derivatives - first term on R.H.S. F(1+KVAR,IVAL)=F(1+KVAR,IVAL)+W(1+K) C Second derivatives - second term on R.H.S. (the first term C vanishes in this case) - loop for the summation index J: DO 32 J=1,NVAR JVAR=IVAR(J) IF(JVAR.LE.3) THEN IF(JVAR.LE.KVAR) THEN N=ISYM(JVAR,KVAR) F(N,IVAL)=F(N,IVAL)+W(ISYM(J,K)) END IF ELSE JVAR=JVAR-3 AUX1=W(ISYM(J,K)) DO 31 I=1,JVAR N=ISYM(I,JVAR) F(N,IVAL)=F(N,IVAL)+AUX1*F(1+I,JVAR) 31 CONTINUE END IF 32 CONTINUE CALL VAR4(4*K+1+KVAR,1.) ELSE KVAR=KVAR-3 DO 33 I=2,4 CALL VAR4(4*K+I,F(I,KVAR)) 33 CONTINUE END IF 39 CONTINUE CALL VAR5(IVAL,0) C Loop for the summation index K: DO 49 K=1,NVAR KVAR=IVAR(K) IF(KVAR.GT.3) THEN KVAR=KVAR-3 CALL VAR4(0,W(1+K)) C First and second derivatives - first terms on R.H.S. DO 44 I=2,10 F(I,IVAL)=F(I,IVAL)+W(1+K)*F(I,KVAR) 44 CONTINUE C Second derivatives - second term on R.H.S. - C loop for the summation index J: DO 48 J=1,NVAR JVAR=IVAR(J) IF(JVAR.LE.3) THEN AUX1=W(ISYM(J,K)) DO 45 I=1,KVAR N=ISYM(I,KVAR) F(N,IVAL)=F(N,IVAL)+AUX1*F(1+I,KVAR) 45 CONTINUE ELSE JVAR=JVAR-3 AUX1=W(ISYM(J,K)) DO 47 M=1,3 AUX2=AUX1*F(1+M,JVAR) DO 46 I=1,M N=ISYM(I,M) F(N,IVAL)=F(N,IVAL)+AUX2*F(1+I,KVAR) 46 CONTINUE CALL VAR4(1+M,AUX2) 47 CONTINUE END IF 48 CONTINUE CALL VAR5(IVAL,KVAR) END IF 49 CONTINUE C END IF 90 CONTINUE C End of loop for evaluated functions F C RETURN END C C======================================================================= Cvar.for 0100666 0000765 0000765 00000030003 06600366604 011733 0 ustar bulant bulant CC Subroutine file 'var.for' to store in the memory variations of the C functions describing the model, with respect to their coefficients. C C Date: 1996, September 30 C Coded by Ludek Klimes C C....................................................................... C C This file consists of the following subroutine and its entries: C VAR1... Subroutine designed to initialize (i.e. to clear) the C memory storage locations. After invocation of this C subroutine no variations are in the memory, thus the C variations at a new point in the model may be started to C be stored (see entry VAR2). C This subroutine contains entries VAR2, VAR3, VAR4, VAR5 C and VAR6 listed below. C VAR1 C VAR2... Entry of the subroutine VAR1, designed to store variations C of the functions describing the model in the memory. C One new variation is stored by one invocation, being added C into the register no. 0. Note that one variation consists C of the variation of the functional value and its three C first derivatives. C VAR2 C VAR3... Entry of the subroutine VAR1, designed to replace the C relative indices of the function coefficients by the C absolute ones in the register 0. It should be called C after the register 0 is filled by the proper number of C invocations of the subroutine VAR2. C VAR3 C VAR4... Entry of the subroutine VAR1, designed to define and/or C rebuild the 4*4 transformation matrix which may be applied C to the stored variations in order to modify them. C VAR4 C VAR5... Entry of the subroutine VAR1, designed to modify the C stored variations by means of a linear transformation, C and to eventually append them to the registers C corresponding to the individual functions describing the C model. The linear transformation is defined by C invocation(s) of the above entry VAR4. C VAR5 C VAR6... Entry of the subroutine VAR1, designed to recall the C stored variations corresponding to a given function C describing the model. C VAR6 C C....................................................................... C C Attention: C (A) When linking this subroutine file with the file 'val.for', C subroutines CURVB1 and CURVBD of the file 'fit.for', instead of C CURVN1 and CURV2D, must be called from the 'val.for' file. This C is the default in the distributed source code. See also the C comment lines with '*' in the first column in the file 'val.for'. C (B) In the basic version of C.R.T. routines, subroutines VAR* are C called from the following subroutine files: C 'model.for' 7 times (in subroutines VELOC and POWER), C 'parm.for' 7 times (in subroutine PARM2), C 'val.for' 21 times (in subroutine VAL2), C 'fit.for' 3 times (in subrs. CURVBD, SURFBD and VAL3BD). C Note that the corresponding call statements contain the substring C ' CALL VAR', and are denoted by '*V' in the first two C columns of the basic versions of the distributed source C code. C Each '*V' in the first two columns of the above mentioned files C has to be replaced by ' ' (2 blanks) if linking with 'var.for'. C C Relative CPU-time usage for the demo data: C CURVN1, CURV2D, no call VAR*: 1.00 C CURVN1, CURV2D, 'VARNUL': 1.16 C CURVB1, CURVBD, no call VAR*: 1.04 C CURVB1, CURVBD, 'VARNUL': 1.22 C CURVB1, CURVBD, 'VAR': 1.88 C C----------------------------------------------------------------------- C C C SUBROUTINE VAR1() C dummy arguments of all entries: INTEGER IBI,IBB,IVAL,IVAL0,II,NBI REAL B0I,B1I,B2I,B3I,BBI C C This subroutine is designed to initialize (i.e. to clear) the memory C storage locations. After invocation of this subroutine no variations C are in the memory, thus the variations at a new point in the model may C be started to be stored (see entry VAR2). C C No input. C C No output. C C No subroutines and external functions required. C C....................................................................... C C Storage locations (common to all entries): C INTEGER MFUNCT,MB PARAMETER (MFUNCT=48,MB=3072) INTEGER NB(0:MFUNCT),IB(MB), IAUX,I,J,JB,JB0,JVAL,JVAL0 REAL B0(MB),B1(MB),B2(MB),B3(MB),BB(16), AUX0,AUX1,AUX2,AUX3 SAVE NB,IB,B0,B1,B2,B3,BB C C....................................................................... C DO 11 I=0,MFUNCT NB(I)=0 11 CONTINUE RETURN C C----------------------------------------------------------------------- C C C ENTRY VAR2(IBI,B0I,B1I,B2I,B3I) C INTEGER IBI C REAL B0I,B1I,B2I,B3I C C This entry is designed to store variations of the functions describing C the model in the memory. One new variation is stored by one C invocation, being added into the register no. 0. Note that one C variation consists of the variation of the functional value and its C three first derivatives. C C Input: C IBI... Index of the function coefficient, relative to the C beginning of the function. C B0I,B1I,B2I,B3I... Variation of the functional value and the three C first derivatives, with respect to the IBI-th coefficient C of the function. C The input parameters are not altered. C C No output. C C....................................................................... C I=NB(MFUNCT)+1 IF(I.GT.MB) THEN C 362 CALL ERROR('362 in VAR2: Array index out of range.') C Dimension MB of arrays IB, B0, B1, B2 and B3 should be C increased. END IF NB(MFUNCT)=I IB(I)=IBI B0(I)=B0I B1(I)=B1I B2(I)=B2I B3(I)=B3I RETURN C C----------------------------------------------------------------------- C C C ENTRY VAR3(IBI) C INTEGER IBI C C This entry is designed to replace the relative indices of the function C coefficients by the absolute ones in the register 0. It should be C called after the register 0 is filled by the proper number of C invocations of the subroutine VAR2. C C Input: C IBI... Shift added to the index of the function coefficient. C It should equal the difference between the absolute (see C entry VAR6) and relative (see entry VAR2) indices of the C corresponding function. C The input parameter is not altered. C C No output. C C....................................................................... C DO 31 I=NB(MFUNCT-1)+1,NB(MFUNCT) IB(I)=IB(I)+IBI 31 CONTINUE RETURN C C----------------------------------------------------------------------- C C C ENTRY VAR4(IBB,BBI) C INTEGER IBB C REAL BBI C C This entry is designed to define and/or rebuild the 4*4 transformation C matrix which may be applied to the stored variations in order to C modify them. C C Input: C IBB... IBB=0: 4*4 transformation matrix is set to the identity C matrix multiplied by BBI. C IBB=1,2,...,16: BBI is added to the IBB-th element of the C transformation matrix. C BBI... Given real value. C The input parameters are not altered. C C No output. C C....................................................................... C IF(IBB.LE.0) THEN DO 41 I=2,15 BB(I)=0. 41 CONTINUE DO 42 I=1,16,5 BB(I)=BBI 42 CONTINUE ELSE BB(IBB)=BB(IBB)+BBI END IF RETURN C C----------------------------------------------------------------------- C C C ENTRY VAR5(IVAL,IVAL0) C INTEGER IVAL,IVAL0 C C This entry is designed to modify the stored variations by means of a C linear transformation, and to eventually append them to the registers C corresponding to the individual functions describing the model. The C linear transformation is defined by invocation(s) of the entry VAR4. C C Input: C IVAL,IVAL0... The variations from the register IVAL0 are C transformed by means of the matrix defined through the C entry VAR4, and then copied to the register IVAL. C The transformed variations are appended to ones already C stored in the IVAL-th register. C If IVAL=IVAL0 or IVAL0=0, the original variations are C deleted from the IVAL0-th register, otherwise the original C variations are retained. C The input parameters are not altered. C C No output. C C....................................................................... C IF(IVAL.LE.0) THEN JVAL=MFUNCT JB=NB(JVAL-1) ELSE JVAL=IVAL IF(IVAL.EQ.IVAL0) THEN JB=NB(JVAL-1) ELSE JB=NB(JVAL) END IF END IF IF(IVAL0.LE.0) THEN JVAL0=MFUNCT ELSE JVAL0=IVAL0 END IF C DO 58 J=1,NB(JVAL0)-NB(JVAL0-1) JB=JB+1 IF(JVAL.EQ.MFUNCT.OR.JVAL0.LT.MFUNCT) THEN JB0=NB(JVAL0-1)+J ELSE JB0=NB(JVAL0-1)+1 END IF IAUX=IB(JB0) AUX0=B0(JB0) AUX1=B1(JB0) AUX2=B2(JB0) AUX3=B3(JB0) IF(JVAL.NE.JVAL0) THEN DO 51 I=JVAL,MFUNCT-1 NB(I)=NB(I)+1 51 CONTINUE IF(JVAL0.LT.MFUNCT) THEN C original variations are not deleted JB0=NB(MFUNCT)+1 NB(MFUNCT)=JB0 END IF END IF IF(JB0.GT.MB) THEN C 365 CALL ERROR('365 in VAR5: Array index out of range.') C Dimension MB of arrays IB, B0, B1, B2 and B3 should be C increased. END IF DO 52 I=JB0-1,JB,-1 IB(I+1)=IB(I) B0(I+1)=B0(I) B1(I+1)=B1(I) B2(I+1)=B2(I) B3(I+1)=B3(I) 52 CONTINUE IB(JB)=IAUX B0(JB)=BB(1)*AUX0+BB(5)*AUX1+BB( 9)*AUX2+BB(13)*AUX3 B1(JB)=BB(2)*AUX0+BB(6)*AUX1+BB(10)*AUX2+BB(14)*AUX3 B2(JB)=BB(3)*AUX0+BB(7)*AUX1+BB(11)*AUX2+BB(15)*AUX3 B3(JB)=BB(4)*AUX0+BB(8)*AUX1+BB(12)*AUX2+BB(16)*AUX3 58 CONTINUE RETURN C C----------------------------------------------------------------------- C C C ENTRY VAR6(IVAL,II,NBI,IBI,B0I,B1I,B2I,B3I) C INTEGER IVAL,II,NBI,IBI C REAL B0I,B1I,B2I,B3I C C This entry is designed to recall the stored variations corresponding C to a given function describing the model. C C Input: C IVAL... Index of the function describing the model. The output C variations are thus recalled from the IVAL-th register. C II... Sequential number within the register of the required C variation of the IVAL-th function. C The input parameters are not altered. C C Output: C NBI... Number of the variations of the IVAL-th function stored in C the IVAL-th register. C IBI... Absolute index of the function coefficient. For II.GT.NBI C undefined. C B0I,B1I,B2I,B3I... Variation of the functional value and the three C first derivatives, with respect to the IBI-th coefficient C of the model. For II.GT.NBI undefined. C C....................................................................... C NBI=NB(IVAL)-NB(IVAL-1) IF(II.LE.NBI) THEN I=NB(IVAL-1)+II IBI=IB(I) B0I=B0(I) B1I=B1(I) B2I=B2(I) B3I=B3(I) END IF RETURN END C C======================================================================= Cvarnul.for 0100666 0000765 0000765 00000005246 06600366662 012471 0 ustar bulant bulant CC Subroutine file 'varnul.for' - empty subroutines VAR1 to VAR6. C C Date: 1996, September 30 C Coded by Ludek Klimes C C....................................................................... C C Subroutine VAR1 and its entries VAR2, VAR3, VAR4 and VAR5 are called C from the model specification subroutines in order to keep in the C memory variations of the functions describing the model, with respect C to their coefficients. The variations are required for the C travel-time inversion of the model and are recalled from the memory by C calling the entry VAR6, see the subroutine file 'var.for'. In the C case of forward modelling, the invocation of subroutines VAR1, VAR2, C VAR3, VAR4 and VAR5 is useless. C C In the case of forward modelling, either: C The complete ray tracing program may be linked with the empty C subroutines of this file, C or: C User may remove the invocations of the subroutines VAR1, VAR2, C VAR3, VAR4 and VAR5 from the model specification subroutine files. C This option saves the CPU time with respect to the former one. C In the basic version of C.R.T. routines, subroutines VAR* are C called from the following subroutine files: C 'model.for' 7 times (in subroutines VELOC and POWER), C 'parm.for' 7 times (in subroutine PARM2), C 'val.for' 21 times (in subroutine VAL2), C 'fit.for' 3 times (in subrs. CURVBD, SURFBD and VAL3BD). C Note that the corresponding call statements contain the substring C ' CALL VAR', and are denoted by '*V' in the first two C columns of the distributed source code. C Attention: there is a continuation line of such a call statement C in the file 'fit.for'. C C----------------------------------------------------------------------- C SUBROUTINE VAR1() C Dummy arguments of all entries: INTEGER IBI,IBB,IVAL,IVAL0,II,IEND REAL B0I,B1I,B2I,B3I,BBI C ENTRY VAR2(IBI,B0I,B1I,B2I,B3I) C ENTRY VAR3(IBI) C ENTRY VAR4(IBB,BBI) C ENTRY VAR5(IVAL,IVAL0) RETURN C ENTRY VAR6(IVAL,II,IEND,IBI,B0I,B1I,B2I,B3I) C 360 CALL ERROR('360 in VAR6: No variations stored') C Model-treating subroutine files are linked with the C dummy subroutine file 'varnul.for' instead of 'var.for'. C No variations are stored in the memory, thus the entry C VAR6 cannot be called. RETURN END C C======================================================================= C