C
C PROGRAM WEAKAN C C******************************************************************* C C PROGRAM WEAKAN IS DESIGNED FOR CALCULATIONS IN THE QI C APPROXIMATION C C******************************************************************* C C CHARACTER*80 MTEXT,FILEIN,FILEOU,FILE1,FILE2 COMPLEX AY,W DIMENSION W(2),DST(100),P1(2000),P2(2000),P3(2000) COMMON /RAYW/ AY(3,2000),E(3,3,2000),OMEGA,N,NTOT,IND,IND1 COMMON /AUXI/ IANI(20),INTR,INT1,IPREC,KRE,IREFR,LAY,NDER,IPRINT, 1 MPRINT,NTR,ISQRT,NAUX,ISOUR,MAUX,MREG,MDIM,IPOL,MSCON,LOU, 2 IAMP,MTRNS,ICOEF,IAD,IRHO,ISHEAR,IAC,IRT,mori COMMON /ISOTR/T(2000),X(2000),Y(2000),Z(2000),VP(2000),VS(2000), 1RHO(2000) COMMON /FORCE/ F(3) C C************************************************** C LIN=5 LOU=6 LU1=1 LU6=2 FILEIN='weakan.dat' FILEOU='weakan.out' FILE1='lu1.dat' FILE2='lu6.dat' WRITE(*,'(2A)') ' (WEAKAN) SPECIFY NAMES OF INPUT AND OUTPUT', 1'FILES LIN, LOU, LU1, LU6: ' READ(*,*) FILEIN,FILEOU,FILE1,FILE2 IF(FILE1.EQ.' ') LU1=0 IF(FILE2.EQ.' ') LU6=0 OPEN(LIN,FILE=FILEIN,FORM='FORMATTED',STATUS='OLD') OPEN(LOU,FILE=FILEOU,FORM='FORMATTED') IF(LU1.NE.0)OPEN(LU1,FILE=FILE1,FORM='FORMATTED',STATUS='OLD') IF(LU6.NE.0)OPEN(LU6,FILE=FILE2,FORM='FORMATTED') C C************************************************** C WRITE(LOU,777) 777 FORMAT(///,'***********************' 1,//,' PROGRAM W E A K A N ',//, 2'***********************',//) MTEXT='WEAKAN' INULL=4 INEWB=0 READ(LIN,*)MTEXT WRITE(LOU,115)MTEXT READ(LIN,*)INULL,INEWB RNULL=10.**(-INULL) WRITE(LOU,100)INULL,INEWB IND1=INEWB C C C SPECIFICATION OF THE MODEL C CALL MODEL(MTEXT,LIN) C READ(LIN,*)F WRITE(LOU,104)F READ(LIN,*)FL,FD,NF WRITE(LOU,102)FL,FD,NF WRITE(LU6,107)FL,FD,NF TSOUR=0. C C READS FILE LU1 FOR WITH INFORMATION ON RAYS C READ(LU1,100)ICONT,NDST,ILOC READ(LU1,104)RO READ(LU1,100)NPN,NPN,NPN READ(LU1,101)APN,APN,APN,APN,APN READ(LU1,101)APN,APN,APN,APN,APN READ(LU1,104)APN,APN,APN,APN READ(LU1,104)(DST(I),I=1,NDST) 2 READ(LU1,103)NTOT,NRAY IF(NTOT.EQ.0)GO TO 5 READ(LU1,105)(T(J),X(J),Y(J),Z(J),P1(J),P2(J),P3(J),VP(J), 1VS(J),RHO(J),(E(1,K,J),K=1,3),(E(2,L,J),L=1,3),J = 1,NTOT) DO 3 J=1,NTOT AUX=SQRT(P1(J)*P1(J)+P2(J)*P2(J)+P3(J)*P3(J)) E(3,1,J)=P1(J)/AUX E(3,2,J)=P2(J)/AUX E(3,3,J)=P3(J)/AUX VP(J)=SQRT(VP(J)) VS(J)=SQRT(VS(J)) 3 CONTINUE LAY=1 C FF=FL WRITE(LU6,105)(E(1,K,NTOT),K=1,3),(E(2,L,NTOT),L=1,3) DO 4 J=1,NF OMEGA=6.2831853*FF CALL RAYB(W,TSOUR,DT) WRITE(LU6,105)FF,W FF=FL+FLOAT(J)*FD 4 CONTINUE GO TO 2 C 100 FORMAT(26I3) 101 FORMAT(5E15.5) 102 FORMAT(2F10.5,I5) 103 FORMAT(2I5) 104 FORMAT(8F10.5) 105 FORMAT(16E15.5) 106 FORMAT(1X,6(F10.5)) 107 FORMAT(2F10.5,I5) 115 FORMAT(A) C 5 CONTINUE STOP END C C C======================================================================= C INCLUDE 'wk.for' C wk.for C C Interpolation method: C Include just one of the following files 'mod*.for': C (a) (Bi-)(tri-)cubic B-spline interpolation: INCLUDE 'modbs.for' C modbs.for C (b) Rotating axis of symmetry: * INCLUDE 'modrt.for' C modrt.for C C======================================================================= C