Coverage Report: SourceReceiverPositions.f90

Generated from GCOV analysis of Fortran source code

56.6%
Lines Executed
99 total lines
53.2%
Branches Executed
284 total branches
100.0%
Calls Executed
41 total calls
0
-
Source:SourceReceiverPositions.f90
0
-
Graph:SourceReceiverPositions.gcno
0
-
Data:SourceReceiverPositions.gcda
0
-
Runs:29
1
-
!! Provides methods to read in depths, depths, bearing data
2
-
3
-
MODULE SourceReceiverPositions
4
-
!! Reads in source depths, receiver depths, receiver ranges, and receiver bearings
5
-
6
-
USE monotonicMod
7
-
USE SortMod
8
-
USE SubTabulate
9
-
USE FatalError
10
-
11
-
IMPLICIT NONE
12
-
PUBLIC
13
-
14
-
INTEGER, PARAMETER :: Number_to_Echo = 10
15
-
INTEGER, PRIVATE :: IAllocStat ! used to capture status after allocation
16
-
INTEGER, PRIVATE, PARAMETER :: ENVFile = 5, PRTFile = 6 ! unit 5 is usually (not always) the ENVFile
17
-
INTEGER :: Nfreq = 1 ! number of frequencies
18
-
REAL (KIND=8), ALLOCATABLE :: freqVec( : ) ! frequency vector for broadband runs
19
-
20
-
TYPE Position
21
-
INTEGER :: NSx = 1, NSy = 1, NSz = 1, NRz = 1, NRr = 1, Ntheta = 1 ! number of x, y, z, r, theta coordinates
22
-
REAL :: Delta_r, Delta_theta
23
-
INTEGER, ALLOCATABLE :: iSz( : ), iRz( : )
24
-
REAL, ALLOCATABLE :: Sx( : ), Sy( : ), Sz( : ) ! Source x, y, z coordinates
25
-
REAL, ALLOCATABLE :: Rr( : ), Rz( : ), ws( : ), wr( : ) ! Receiver r, z coordinates and weights for interpolation
26
-
REAL, ALLOCATABLE :: theta( : ) ! Receiver bearings
27
-
END TYPE Position
28
-
29
-
TYPE ( Position ) :: Pos ! structure containing source and receiver positions
30
-
31
-
CONTAINS
32
-
33
#####
FUNCTION RToIR( r )
34
-
35
-
! index of nearest rcvr before normal
36
-
! Compute upper index on rcvr line
37
-
!!! Assumes Pos%r is a vector of equally spaced points
38
-
39
-
REAL ( KIND=8 ), INTENT( IN ) :: r
40
-
INTEGER :: RToIR, ti
41
-
REAL ( KIND=8 ) :: temp
42
-
43
#####
temp = ( r - Pos%Rr( 1 ) ) / Pos%Delta_r
44
-
! LP: Added snapping to deal with floating-point error at the int boundaries.
45
#####
IF ( ABS( temp - REAL( NINT( temp ), 8 ) ) < 1D-6 ) THEN
46
#####
temp = REAL( NINT( temp ), 8 )
47
-
END IF
48
-
! mbp: should be ", 0 )" ? [LP: on 2D Cerveny cart]
49
#####
RToIR = MAX( MIN( INT( temp ) + 1, Pos%NRr ), 1 )
50
-
51
#####
END FUNCTION RToIR
52
-
53
14*
SUBROUTINE ReadfreqVec( freq0, BroadbandOption )
54
-
55
-
! Optionally reads a vector of source frequencies for a broadband run
56
-
! If the broadband option is not selected, then the input freq (a scalar) is stored in the frequency vector
57
-
58
-
REAL (KIND=8), INTENT( IN ) :: freq0 ! Nominal or carrier frequency
59
-
CHARACTER(LEN=1), INTENT(IN) :: BroadbandOption
60
-
INTEGER :: ifreq
61
-
62
-
! Broadband run?
63
14
IF ( BroadbandOption == 'B' ) THEN
64
#####
READ( ENVFile, * ) Nfreq
65
#####
WRITE( PRTFile, * ) '__________________________________________________________________________'
66
#####
WRITE( PRTFile, * )
67
#####
WRITE( PRTFile, * )
68
#####
WRITE( PRTFile, * ) ' Number of frequencies =', Nfreq
69
#####
IF ( Nfreq <= 0 ) CALL ERROUT( 'ReadEnvironment', 'Number of frequencies must be positive' )
70
-
END IF
71
-
72
14*
IF ( ALLOCATED( freqVec ) ) DEALLOCATE( freqVec )
73
14*
ALLOCATE( freqVec( MAX( 3, Nfreq ) ), Stat = IAllocStat )
74
14*
IF ( IAllocStat /= 0 ) CALL ERROUT( 'ReadEnvironment', 'Too many frequencies' )
75
-
76
14*
IF ( BroadbandOption == 'B' ) THEN
77
#####
WRITE( PRTFile, * ) ' Frequencies (Hz)'
78
#####
freqVec( 2 ) = -999.9
79
#####
freqVec( 3 ) = -999.9
80
#####
READ( ENVFile, * ) freqVec( 1 : Nfreq )
81
#####
CALL SubTab( freqVec, Nfreq )
82
-
83
#####
WRITE( PRTFile, "( 5G14.6 )" ) ( freqVec( ifreq ), ifreq = 1, MIN( Nfreq, Number_to_Echo ) )
84
#####
IF ( Nfreq > Number_to_Echo ) WRITE( PRTFile, "( G14.6 )" ) ' ... ', freqVec( Nfreq )
85
-
ELSE
86
14*
freqVec( 1 ) = freq0
87
-
END IF
88
-
89
14
RETURN
90
-
91
-
END SUBROUTINE ReadfreqVec
92
-
93
-
! ********************************************************************!
94
-
95
14
SUBROUTINE ReadSxSy( ThreeD )
96
-
97
-
! Reads source x-y coordinates
98
-
99
-
LOGICAL, INTENT( IN ) :: ThreeD ! flag indicating whether this is a 3D run
100
-
101
14*
IF ( ThreeD ) THEN
102
#####
CALL ReadVector( Pos%NSx, Pos%Sx, 'Source x-coordinates, Sx', 'km' )
103
#####
CALL ReadVector( Pos%NSy, Pos%Sy, 'Source y-coordinates, Sy', 'km' )
104
-
ELSE
105
14*
ALLOCATE( Pos%Sx( 1 ), Pos%Sy( 1 ) )
106
14*
Pos%Sx( 1 ) = 0.
107
14*
Pos%Sy( 1 ) = 0.
108
-
END IF
109
-
110
14
RETURN
111
-
END SUBROUTINE ReadSxSy
112
-
113
-
! ********************************************************************!
114
-
115
14
SUBROUTINE ReadSzRz( zMin, zMax )
116
-
117
-
! Reads source and receiver z-coordinates (depths)
118
-
! zMin and zMax are limits for those depths; sources and receivers are shifted to be within those limits
119
-
120
-
REAL, INTENT( IN ) :: zMin, zMax
121
-
!LOGICAL :: monotonic
122
-
123
14*
CALL ReadVector( Pos%NSz, Pos%Sz, 'Source z-coordinates, Sz', 'm' )
124
14*
CALL ReadVector( Pos%NRz, Pos%Rz, 'Receiver z-coordinates, Rz', 'm' )
125
-
126
14*
IF ( ALLOCATED( Pos%ws ) ) DEALLOCATE( Pos%ws, Pos%iSz )
127
14*
ALLOCATE( Pos%ws( Pos%NSz ), Pos%iSz( Pos%NSz ), Stat = IAllocStat )
128
14*
IF ( IAllocStat /= 0 ) CALL ERROUT( 'ReadSzRz', 'Too many sources' )
129
-
130
14*
IF ( ALLOCATED( Pos%wr ) ) DEALLOCATE( Pos%wr, Pos%iRz )
131
14*
ALLOCATE( Pos%wr( Pos%NRz ), Pos%iRz( Pos%NRz ), Stat = IAllocStat )
132
14*
IF ( IAllocStat /= 0 ) CALL ERROUT( 'ReadSzRz', 'Too many receivers' )
133
-
134
-
! *** Check for Sz/Rz in upper or lower halfspace ***
135
-
136
28*
IF ( ANY( Pos%Sz( 1 : Pos%NSz ) < zMin ) ) THEN
137
#####
WHERE ( Pos%Sz < zMin ) Pos%Sz = zMin
138
#####
WRITE( PRTFile, * ) 'Warning in ReadSzRz : Source above or too near the top bdry has been moved down'
139
-
END IF
140
-
141
28*
IF ( ANY( Pos%Sz( 1 : Pos%NSz ) > zMax ) ) THEN
142
#####
WHERE( Pos%Sz > zMax ) Pos%Sz = zMax
143
#####
WRITE( PRTFile, * ) 'Warning in ReadSzRz : Source below or too near the bottom bdry has been moved up'
144
-
END IF
145
-
146
1328*
IF ( ANY( Pos%Rz( 1 : Pos%NRz ) < zMin ) ) THEN
147
#####
WHERE( Pos%Rz < zMin ) Pos%Rz = zMin
148
#####
WRITE( PRTFile, * ) 'Warning in ReadSzRz : Receiver above or too near the top bdry has been moved down'
149
-
END IF
150
-
151
1328*
IF ( ANY( Pos%Rz( 1 : Pos%NRz ) > zMax ) ) THEN
152
#####
WHERE( Pos%Rz > zMax ) Pos%Rz = zMax
153
#####
WRITE( PRTFile, * ) 'Warning in ReadSzRz : Receiver below or too near the bottom bdry has been moved up'
154
-
END IF
155
-
156
-
!!$ IF ( .NOT. monotonic( Pos%sz, Pos%NSz ) ) THEN
157
-
!!$ CALL ERROUT( 'SzRzRMod', 'Source depths are not monotonically increasing' )
158
-
!!$ END IF
159
-
!!$
160
-
!!$ IF ( .NOT. monotonic( Pos%rz, Pos%NRz ) ) THEN
161
-
!!$ CALL ERROUT( 'SzRzRMod', 'Receiver depths are not monotonically increasing' )
162
-
!!$ END IF
163
-
164
14
RETURN
165
28
END SUBROUTINE ReadSzRz
166
-
167
-
! ********************************************************************!
168
-
169
14
SUBROUTINE ReadRcvrRanges
170
-
171
14*
CALL ReadVector( Pos%NRr, Pos%Rr, 'Receiver r-coordinates, Rr', 'km' )
172
-
173
-
! calculate range spacing
174
14
Pos%delta_r = 0.0
175
14*
IF ( Pos%NRr /= 1 ) Pos%delta_r = Pos%Rr( Pos%NRr ) - Pos%Rr( Pos%NRr - 1 )
176
-
177
14*
IF ( .NOT. monotonic( Pos%rr, Pos%NRr ) ) THEN
178
#####
CALL ERROUT( 'ReadRcvrRanges', 'Receiver ranges are not monotonically increasing' )
179
-
END IF
180
-
181
14
RETURN
182
-
END SUBROUTINE ReadRcvrRanges
183
-
184
-
! ********************************************************************!
185
-
186
#####
SUBROUTINE ReadRcvrBearings
187
-
188
#####
CALL ReadVector( Pos%Ntheta, Pos%theta, 'Receiver bearings, theta', 'degrees' )
189
-
190
-
! full 360-degree sweep? remove duplicate angle
191
#####
IF ( Pos%Ntheta > 1 ) THEN
192
#####
IF ( ABS( MOD( Pos%theta( Pos%Ntheta ) - Pos%theta( 1 ), 360.0 ) ) < 10.0 * TINY( 1.0D0 ) ) &
193
#####
Pos%Ntheta = Pos%Ntheta - 1
194
-
END IF
195
-
196
-
! calculate angular spacing
197
#####
Pos%Delta_theta = 0.0
198
#####
IF ( Pos%Ntheta /= 1 ) Pos%Delta_theta = Pos%theta( Pos%Ntheta ) - Pos%theta( Pos%Ntheta - 1 )
199
-
200
#####
IF ( .NOT. monotonic( Pos%theta, Pos%Ntheta ) ) THEN
201
#####
CALL ERROUT( 'ReadRcvrBearings', 'Receiver bearings are not monotonically increasing' )
202
-
END IF
203
-
204
#####
RETURN
205
-
END SUBROUTINE ReadRcvrBearings
206
-
207
-
! ********************************************************************!
208
-
209
42
SUBROUTINE ReadVector( Nx, x, Description, Units )
210
-
211
-
! Read a vector x
212
-
! Description is something like 'receiver ranges'
213
-
! Units is something like 'km'
214
-
215
-
INTEGER, INTENT( OUT ) :: Nx
216
-
REAL, ALLOCATABLE, INTENT( OUT ) :: x( : )
217
-
CHARACTER, INTENT( IN ) :: Description*( * ), Units*( * )
218
-
INTEGER :: ix
219
-
220
42
WRITE( PRTFile, * )
221
42
WRITE( PRTFile, * ) '__________________________________________________________________________'
222
42
WRITE( PRTFile, * )
223
-
224
42
READ( ENVFile, * ) Nx
225
42*
WRITE( PRTFile, * ) ' Number of ' // Description // ' = ', Nx
226
-
227
42*
IF ( Nx <= 0 ) CALL ERROUT( 'ReadVector', 'Number of ' // Description // 'must be positive' )
228
-
229
42*
IF ( ALLOCATED( x ) ) DEALLOCATE( x )
230
42*
ALLOCATE( x( MAX( 3, Nx ) ), Stat = IAllocStat )
231
42*
IF ( IAllocStat /= 0 ) CALL ERROUT( 'ReadVector', 'Too many ' // Description )
232
-
233
42*
WRITE( PRTFile, * ) ' ', Description // ' (' // Units // ')'
234
42*
x( 3 ) = -999.9
235
42*
READ( ENVFile, * ) x( 1 : Nx )
236
-
237
42*
CALL SubTab( x, Nx )
238
42*
CALL Sort( x, Nx )
239
-
240
143*
WRITE( PRTFile, "( 5G14.6 )" ) ' ', ( x( ix ), ix = 1, MIN( Nx, Number_to_Echo ) )
241
42*
IF ( Nx > Number_to_Echo ) WRITE( PRTFile, "( G14.6 )" ) ' ... ', x( Nx )
242
-
243
42
WRITE( PRTFile, * )
244
-
245
-
! Vectors in km should be converted to m for internal use
246
42
IF ( LEN_TRIM( Units ) >= 2 ) THEN
247
2052*
IF ( Units( 1 : 2 ) == 'km' ) x = 1000.0 * x
248
-
END IF
249
-
250
126
END SUBROUTINE ReadVector
251
-
252
#####
END MODULE SourceReceiverPositions
252
#####
END MODULE SourceReceiverPositions
252
#####
END MODULE SourceReceiverPositions

Legend:

Execution Count: Number of times each line was executed. ##### indicates never executed, - indicates non-executable.