C
C Subroutine file 'apw.for': Subroutines writing the quantities at the C points of rays into unformatted output files. The quantities are C stored in common block /POINTC/. C C Version: 7.00 C Date: 2013, February 26 C Coded by Ludek Klimes C C This file consists of the following external procedures: C APW1... Subroutine designed to write the initial point of a ray, C stored in common block /POINTC/, into the output C unformatted file. C APW1 C APW2... Subroutine designed to write the current point of a ray, C stored in common block /POINTC/, into the output C unformatted file. C This subroutine is thus designed for writing the ray point C by point directly into the output file. C APW2 C APW3... Subroutine designed to copy the current point of a ray, C stored in common block /POINTC/, to two stock arrays, C in order to write the whole ray at once later. C This subroutine together with APW4 is thus designed for C situations, in which we cannot write the ray point by C point directly into the output file. C APW3 C APW4... Subroutine designed to write all points of a ray, already C stored by subroutine APW3 in the stock arrays, into the C output unformatted file. C APW4 C C======================================================================= C C C SUBROUTINE APW1(LU) INTEGER LU C C This subroutine writes the initial point of a ray, stored in common C block /POINTC/, into the output unformatted file. C C Input: C LU... Logical unit number of the external output device C containing an unformatted file with the quantities at C the initial points of rays. C C No Output. C C Common block /POINTC/: INCLUDE 'pointc.inc' C pointc.inc C C Date: 2013, February 19 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I1,I2,I C C....................................................................... C IF(NPVI.EQ.3) THEN I1=7 I2=9 ELSE I1=1 I2=NPVI END IF WRITE(LU) ISRC,-IWAVE,IRAY,ICB1I,IEND,ISHEET,IREC,YLI,YI, * NPVI,(PVI(I),I=I1,I2) RETURN END C C======================================================================= C C C SUBROUTINE APW2(LU) INTEGER LU C C This subroutine writes the current point of a ray, stored in common C block /POINTC/, into the output unformatted file. C This subroutine is thus designed for writing the ray point by point. C C Input: C LU... Logical unit number of the external output device C containing an unformatted file with the quantities at C the points along rays. C C No Output. C C Common block /POINTC/: INCLUDE 'pointc.inc' C pointc.inc C C Date: 2013, February 16 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I1,I2,I C C....................................................................... C IF(NPV.EQ.3) THEN I1=7 I2=9 ELSE I1=1 I2=NPV END IF WRITE(LU) ISRC,IWAVE,IRAY,NY,ICB1,ISRF,KMAH, * X,UEBRAY,YL,(Y(I),I=1,NY),NPV,(PV(I),I=I1,I2) RETURN END C C======================================================================= C C C SUBROUTINE APW3(ISTOK,MISTOK,STOK,MSTOK) INTEGER MISTOK,MSTOK INTEGER ISTOK(MISTOK) REAL STOK(MSTOK) C C This subroutine copies the current point of a ray, stored in common C block /POINTC/, to two stock arrays, in order to write the whole ray C at once later. This subroutine together with APW4 is thus designed C for situations, in which we cannot write the ray point by point C directly into the output file, e.g., when writing two-point rays only C or when simultaneously storing several rays. C C Input: C ISTOK,STOK... Stock arrays to accumulate all points of a ray. C Set ISTOK(1)=0 before the first invocation of APW3. C The stored ray can be deleted by setting ISTOK(1)=0. C MISTOK..Dimension of stock array ISTOK. C To store NPTS points, MISTOK should be at least 8*NPTS+1. C MSTOK...Dimension of stock array STOK. C To store NPTS points, MSTOK should be at least C (8+NY+NPV)*NPTS, see common block /POINTC/. C Examples: C P-P wave in isotropic media: at least 37*NPTS. C S-S wave in isotropic media: at least 43*NPTS. C P-P wave in anisotropic media: at least 40*NPTS. C S-S wave in anisotropic media: at least 49*NPTS. C C Output: C ISTOK,STOK... Updated input arrays. C C Common block /POINTC/: INCLUDE 'pointc.inc' C pointc.inc C C Date: 2013, February 21 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER I INTEGER NISTOK,NSTOK,NPTS SAVE NISTOK,NSTOK,NPTS DATA NISTOK,NSTOK,NPTS/0,0,0/ C C....................................................................... C IF(ISTOK(1).EQ.0) THEN C New ray NISTOK=0 NSTOK=0 NPTS=0 END IF C IF(NISTOK+9.GT.MISTOK) THEN C APW-01 CALL ERROR('APW-01: Small stock array ISTOK for ray points') C Subroutine APW3 is called in order to store the points of a ray C in order to write the whole ray into the unformatted output file C later. The array corresponding to dummy argument ISTOK of C subroutine APW3 is too small to accommodate all points of a ray. C You may increase the dimension of the array, or increase step C STORE in the independent variable along the ray. END IF IF(NSTOK+8+NY+NPV.GT.MSTOK) THEN C APW-02 CALL ERROR('APW-02: Small stock array STOK for ray points') C Subroutine APW3 is called in order to store the points of a ray C in order to write the whole ray into the unformatted output file C later. The array corresponding to dummy argument STOK of C subroutine APW3 is too small to accommodate all points of a ray. C You may increase the dimension of the array, or increase step C STORE in the independent variable along the ray. END IF NPTS=NPTS+1 IF(NPTS.NE.MAX0(1,IPT)) THEN C APW-03 CALL ERROR('APW-03: Incorrect index of the point on a ray') C Serial index of the point on a ray does not correspond to the C value of IPT in common block /POINTC/. C This error should not appear. Contact the authors. END IF IF(ISRC.LE.0) THEN C APW-04 CALL ERROR('APW-04: Index of the source is not positive') C The index of the source (value of ISRC in common block /POINTC/. C is not positive. C This error should not appear. Contact the authors. END IF C ISTOK(NISTOK+1)=ISRC ISTOK(NISTOK+2)=IWAVE ISTOK(NISTOK+3)=IRAY ISTOK(NISTOK+4)=NY ISTOK(NISTOK+5)=ICB1 ISTOK(NISTOK+6)=ISRF ISTOK(NISTOK+7)=KMAH STOK(NSTOK+1)=X STOK(NSTOK+2)=UEBRAY DO 11 I=1,6 STOK(NSTOK+2+I)=YL(I) 11 CONTINUE DO 12 I=1,NY STOK(NSTOK+8+I)=Y(I) 12 CONTINUE ISTOK(NISTOK+8)=NPV DO 13 I=1,NPV STOK(NSTOK+8+NY+I)=PV(I) 13 CONTINUE C ISTOK(NISTOK+9)=0 NISTOK=NISTOK+8 NSTOK=NSTOK+8+NY+NPV RETURN END C C======================================================================= C C C SUBROUTINE APW4(LU,ISTOK,STOK) INTEGER LU,ISTOK(*) REAL STOK(*) C C This subroutine writes all points of a ray, already stored by C subroutine APW3 in the stock arrays, into the output unformatted file. C C Input: C LU... Logical unit number of the external output device C containing an unformatted file with the quantities at C the points along rays. C ISTOK,STOK... Output arrays of subroutine APW3. C C Output: C ISTOK(1)=0 C C Common block /POINTC/: INCLUDE 'pointc.inc' C pointc.inc C C Date: 2013, February 26 C Coded by Ludek Klimes C C----------------------------------------------------------------------- C C Auxiliary storage locations: INTEGER II,IS,ISY,ISPV,I C C....................................................................... C II=0 IS=0 C C Loop over the points of the ray: 10 CONTINUE IF(ISTOK(II+1).EQ.0) THEN C End of the ray GO TO 90 END IF ISY=IS+8+ISTOK(II+4) ISPV=ISY+ISTOK(II+8) WRITE(LU) (ISTOK(I),I=II+1,II+7), * (STOK(I),I=IS+1,ISY), * ISTOK(II+8), * (STOK(I),I=ISY+1,ISPV) II=II+8 IS=ISPV GO TO 10 C 90 CONTINUE ISTOK(1)=0 RETURN END C C======================================================================= C