C FILE EXACT.F C ****************************************************************** C C *********** C * UBCON3D * C *********** SUBROUTINE UBCON3D C ****************************************************************** C *** USER BOTTOM BOUNDARY CONDITION SUBROUTINE C ****************************************************************** INCLUDE 'FOR3D.CMN' ZI=(N+1)*DZ ALFA0=U1 BETA0=U2 GAM0=.5*PI/ZA DO 250 J=1,NSOL+2 ANGR=-FLDW/2.0*PI/180.0+((J-2)*PHI)+(U3*PI/180.0) RADR=RA-DR BOTX(J)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RA)))* CCEXP(CMPLX(0.0,XK0*RA*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) BOTY(J)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RADR)))* CCEXP(CMPLX(0.0,XK0*RADR*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) 250 CONTINUE RETURN END C *********** C * UBOTTOM * C *********** SUBROUTINE UBOTTOM C *** USER WRITES THIS ROUTINE C *** BOTTOM PROFILE - RANGE,DEPTH INCLUDE 'FOR3D.CMN' DO 24 L=1,NSOL TRACK(1,1,L)=0.0 ! RANGE IN METERS TRACK(1,2,L)=40.0 ! DEPTH IN METERS TRACK(2,1,L)=4000.0 TRACK(2,2,L)=40.0 C *** EXTEND LAST DEPTH BEYOND MAX RANGE. TRACK(3,1,L)=1.0E+38 TRACK(3,2,L)=TRACK(2,2,L) R2(L)=TRACK(1,1,L) Z2(L)=TRACK(1,2,L) 24 CONTINUE ZBOT=40.0 RETURN END C *********** C * UEXACT * C *********** SUBROUTINE UEXACT C ****************************************************************** C * EXACT SOLUTION - USED FOR TEST PURPOSES C * SEE "ANALYTICAL SOLUTIONS FOR TESTING ACCURACY AND AZIMUTHAL C * COUPLING IN THREE-DIMENSIONAL ACOUSTIC PROPAGATION" IN C * COMPUTATIONAL ACOUSTICS - VOL 1 - PG 129 - PROCEEDINGS C * 0F THE 2ND IMACS SYMPOSIUM ON COMPUTATIONAL ACOUSTICS- C * PRINCETON, NJ, USA, 15-17 MARCH,1989 - NORTH HOLLAND C * USER COMPUTES EXACT SOLUTION UB AT PRESENT RANGE 'RA', DEPTH 'ZI', C * AND AZIMUTH 'ANGR'. MAIN PROGRAM COMPUTES 'UA'. RELATIVE ERROR C * MAY BE COMPUTED AS SHOWN BELOW. C ****************************************************************** INCLUDE 'FOR3D.CMN' ALFA0=U1 BETA0=U2 GAM0=.5*PI/ZA ANGR=ANG+U3*PI/180.0 UB=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RA)))* CCEXP(CMPLX(0.0,XK0*RA*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) PL=-20.0*ALOG10(CABS(UB))+10.0*ALOG10(RA) UC=(UA-UB) WRITE(6,120) PL,UB 120 FORMAT(20X,3X,F10.3,3X,'(',E12.5,2X,E12.5,' )') RELERR=CABS(UC/UB) WRITE(6,150) UC,RELERR 150 FORMAT(36X,'(',E12.5,2X,E12.5,' )',2X,E12.5) RETURN END C *********** C * UPORT3D * C *********** SUBROUTINE UPORT3D C ****************************************************************** C * PORT SIDEWALL BOUNDARY CONDITION C ****************************************************************** INCLUDE 'FOR3D.CMN' C ALFA0=U1 BETA0=U2 GAM0=.5*PI/ZA J=0 ANGR=-FLDW/2.0*PI/180.0+((J-1)*PHI)+(U3*PI/180.0) DO 100 I=1,N ZI=I*DZ RADR=RA-DR PORTX(I)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RA)))* CCEXP(CMPLX(0.0,XK0*RA*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) PORTY(I)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RADR)))* CCEXP(CMPLX(0.0,XK0*RADR*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) 100 CONTINUE RETURN END C *********** C * USCON3D * C *********** SUBROUTINE USCON3D C ***************************************************************** C *** USER SURFACE BOUNDARY CONDITION SUBROUTINE C ***************************************************************** INCLUDE 'FOR3D.CMN' ZI=0.0 ALFA0=U1 BETA0=U2 GAM0=.5*PI/ZA DO 250 J=1,NSOL+2 ANGR=-FLDW/2.0*PI/180.0+((J-2)*PHI)+(U3*PI/180.0) RADR=RA-DR SURX(J)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RA)))* CCEXP(CMPLX(0.0,XK0*RA*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) SURY(J)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RADR)))* CCEXP(CMPLX(0.0,XK0*RADR*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) 250 CONTINUE RETURN END C *********** C * USFLD3D * C *********** SUBROUTINE USFLD3D C ****************************************************************** C * STARTING FIELD C ****************************************************************** C *************************************************************** C *** USER STARTING FIELD C *** USER WRITES THIS SUBROUTINE IF GAUSSIAN FIELD NOT DESIRED C *** USFLD3D IS CALLED IF ISF = 1 C *************************************************************** C *** UFIELD SUBROUTINE SUPPLIES: C *** U - COMPLEX STARTING FIELD C *************************************************************** INCLUDE 'FOR3D.CMN' ALFA0=U1 BETA0=U2 GAM0=.5*PI/ZA DO 200 J=1,NSOL M=(J-1)*N ANGR=-FLDW/2.0*PI/180.0+((J-1)*PHI)+(U3*PI/180.0) DO 100 I=1,N ZI=I*DZ U(M+I)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RA)))* CCEXP(CMPLX(0.0,XK0*RA*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) 100 CONTINUE 200 CONTINUE RETURN END C *********** C * USTBD3D * C *********** SUBROUTINE USTBD3D C ****************************************************************** C * STARBOARD SIDEWALL BOUNDARY CONDITION C ****************************************************************** INCLUDE 'FOR3D.CMN' C ALFA0=U1 BETA0=U2 GAM0=.5*PI/ZA J=NSOL+1 ANGR=-FLDW/2.0*PI/180.0+((J-1)*PHI)+(U3*PI/180.0) DO 100 I=1,N ZI=I*DZ RADR=RA-DR STBDX(I)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RA)))* CCEXP(CMPLX(0.0,XK0*RA*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) STBDY(I)=SIN(GAM0*ZI)*SIN(BETA0*XK0*(ANGR-ALFA0*LOG(RADR)))* CCEXP(CMPLX(0.0,XK0*RADR*(ALFA0*ANGR-.5*(GAM0/XK0)**2.0))) 100 CONTINUE RETURN END C *********** C * USVP3D * C *********** SUBROUTINE USVP3D C ****************************************************************** C * USER 3D SOUND SPEED PROFILES C * EXACT SOLUTION - COMPUTATIONAL ACOUSTICS - VOLUME 1 - PG 129 C * EQUATION 3.8 C ****************************************************************** C SUBROUTINE USVP3D IS CALLED EACH DR IN RANGE AS LONG AS C KSVP IS NOT ZERO. KSVP MAY BE USED BY USER TO TRANSFER CONTROL C IN THIS SUBROUTINE. USER INSERTS LOGIC TO CLEAR KSVP C WHEN USVP IS NO LONGER NEEDED. IF KSVP NOT CLEARED BY USER, C USVP IS CALLED EACH STEP IN RANGE UNTIL RA = NEXT RSVP. C ****************************************************************** C *** USVP SUBROUTINE RETURNS: C NLYR - NUMBER OF LAYERS. LAYER 1 IS WATER. OTHERS ARE SEDIMENT C ZLYR - ARRAY - DEPTH OF EACH LAYER. FIRST IS DEPTH OF WATER. C RHO - ARRAY - DENSITY OF EACH LAYER. GRAMS/CUBIC CM C RHOG - ARRAY - DENSITY GRADIENT C BETA - ARRAY - ATTENUATION IN EACH LAYER. DB/WAVELENGTH C BETAG - ARRAY - ATTENUATION GRADIENT C IXSVP - ARRAY - CONTAINS POINTERS. POINTS TO LAST VALUE OF SVP C IN CORRESPONDING LAYER. SVP IS STORED IN ARRAYS ZSVP C AND CSVP. IXSVP(1) POINTS TO LAST SVP POINT IN WATER. C NSVP - NUMBER OF POINTS IN ZSVP AND CSVP. ZSVP AND CSVP C CONTAIN THE PROFILES FOR ALL LAYERS. C ZSVP - ARRAY - SVP DEPTHS - METERS C CSVP - ARRAY - SOUND SPEED - METERS/SEC C KSVP - AS DESCRIBED ABOVE. C ****************************************************************** INCLUDE 'FOR3D.CMN' GO TO (100,200,300,400) ,KSVP NSVP=0 RETURN C 100 CONTINUE C *** EXACT SOLUTION NSVP=101 IF(N.LT.NSVP)NSVP=N+2 SVPDZ=ZA/(NSVP-1) ALFA0=U1 BETA0=U2 DO 150 L=1,NSOL NLYR=1 NLYRS(L)=NLYR M=(L-1)*N ANGR=(-FLDW/2.0+(L-1)*DTH)*PI/180.0+(U3*PI/180.0) RHO(1,L)=1.0 RHOG(1,L)=0.0 BETA(1,L)=0.0 BETAG(1,L)=0.0 ZLYR(1,L)=ZA DO 120 I=1,NSVP ZI=(I-1)*SVPDZ ZSVP(I,L)=ZI CSVP(I,L)=C0/SQRT(1+ALFA0*ALFA0+2*ALFA0*ANGR+BETA0*BETA0/(RA*RA)) IXSVP(1,L)=NSVP 120 CONTINUE 150 CONTINUE RETURN C 200 CONTINUE C *** USER INSERTS CODE HERE IF DESIRED RETURN C 300 CONTINUE C *** USER INSERTS CODE HERE IF DESIRED RETURN C 400 CONTINUE C *** USER INSERTS CODE HERE IF DESIRED RETURN END