From bae30915c0829cb798a27c407fbd1b1105728e6e Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Wed, 11 Sep 2024 12:19:29 -0500 Subject: [PATCH 01/13] init fixed f90 interface --- src/ihop_init_fixed_env.F90 | 916 ++++++++++++++++++++++++++++++++++++ 1 file changed, 916 insertions(+) create mode 100644 src/ihop_init_fixed_env.F90 diff --git a/src/ihop_init_fixed_env.F90 b/src/ihop_init_fixed_env.F90 new file mode 100644 index 0000000..ffacb3b --- /dev/null +++ b/src/ihop_init_fixed_env.F90 @@ -0,0 +1,916 @@ +#include "IHOP_OPTIONS.h" +!BOP +! !ROUTINE: ihop_init_fixed_env +! !INTERFACE: + + USE ihop_mod, only: rad2deg, i, Beam, ray2D, NRz_per_range, afreq, & + SrcDeclAngle, iSmallStepCtr, & + PRTFile, SHDFile, ARRFile, RAYFile, DELFile + USE initenvihop, only: initEnv, openOutputFiles, resetMemory + USE angle_mod, only: Angles, ialpha + USE srPos_mod, only: Pos + USE ssp_mod, only: evalSSP, SSP + !HSInfo, Bdry, + USE bdry_mod, only: initATI, initBTY, GetTopSeg, GetBotSeg, Bot, Top, & + atiType, btyType, IsegTop, IsegBot, & + rTopSeg, rBotSeg, Bdry + USE refCoef, only: readReflectionCoefficient, & + InterpolateReflectionCoefficient, & + RTop, RBot, NBotPts, NTopPts + USE influence, only: InfluenceGeoHatRayCen, & + InfluenceGeoGaussianCart, InfluenceGeoHatCart, & + ScalePressure + USE beamPattern + USE writeRay, only: WriteRay2D, WriteDel2D + USE arr_mod, only: WriteArrivalsASCII,WriteArrivalsBinary,MaxNArr, & + Arr, NArr, U + +! !USES: + IMPLICIT NONE +! == Global variables == +#include "SIZE.h" +#include "GRID.h" +#include "EEPARAMS.h" +#include "EESUPPORT.h" +#include "PARAMS.h" +#include "IHOP_SIZE.h" +#include "IHOP.h" +#ifdef ALLOW_CTRL +# include "CTRL_FIELDS.h" +#endif + +! == External Functions == + INTEGER ILNBLNK + EXTERNAL ILNBLNK + + SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) + ! !INPUT/OUTPUT PARAMETERS: + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + INTEGER :: iostat, iAllocStat, ierr + INTEGER :: jj + REAL :: Tstart, Tstop + ! added locally previously read in from unknown mod ... IEsco22 + CHARACTER ( LEN=2 ) :: AttenUnit + ! =========================================================================== + INTEGER :: iSeg + INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 + ! =========================================================================== + + ! Use data.ihop, set time series invariant parameters. These are fixed + ! parameters that do not depend on which time step you run ihop in. + ! Primarily, the parameters are related to the acoustic grid: + ! - From initenvihop.F90:initEnv + ! - Bdry%Top, Bdry%Bot, + ! SSP%AttenUnit,Type,Nr,Nz,z,SSP%Seg%r, + ! Pos%Sx,Sy,Nsz,Nrz,Sz,Rz,Ws,Isz,Wr,Irz,Nrr,Rr,Delta_r, + ! Beam%RunType,Deltas,Nimage,iBeamWindow,Component,Multiplier,rloop, + ! Beam%Box%r,Box%z,Type, + ! Angles%Nalpha,alpha, + ! - From bdry_mod.F90:initATI + ! - Top%Natipts,x, + ! - From bdry_mod.F90:initBTY + ! - Bot%Natipts,x, + ! This subroutine will set parameters that shouldn't need to be modified + ! throughout the MITgcm model run + + ! save data.ihop, gcm SSP: REQUIRED + CALL initEnv( myTime, myIter, myThid ) + ! AlTImetry: OPTIONAL, default is no ATIFile + CALL initATI( Bdry%Top%HS%Opt( 5:5 ), Bdry%Top%HS%Depth, myThid ) + ! BaThYmetry: OPTIONAL, default is BTYFile + CALL initBTY( Bdry%Bot%HS%Opt( 2:2 ), Bdry%Bot%HS%Depth, myThid ) + ! (top and bottom): OPTIONAL + CALL readReflectionCoefficient( Bdry%Bot%HS%Opt( 1:1 ), & + Bdry%Top%HS%Opt( 2:2 ), myThid ) + ! Source Beam Pattern: OPTIONAL, default is omni source pattern + SBPFlag = Beam%RunType( 3:3 ) + CALL readPat( myThid ) + Pos%Ntheta = 1 + ALLOCATE( Pos%theta( Pos%Ntheta ), Stat = IAllocStat ) + IF ( IAllocStat/=0 ) THEN +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: failed allocation Pos%theta' + CALL PRINT_ERROR( msgBuf, myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R IHOP_INIT' + ENDIF + Pos%theta( 1 ) = 0. + + +! Allocate arrival and U variables on all MPI processes + SELECT CASE ( Beam%RunType( 5:5 ) ) + CASE ( 'I' ) + NRz_per_range = 1 ! irregular grid + CASE DEFAULT + NRz_per_range = Pos%NRz ! rectilinear grid + END SELECT + + IF ( ALLOCATED( U ) ) DEALLOCATE( U ) + SELECT CASE ( Beam%RunType( 1:1 ) ) + ! for a TL calculation, allocate space for the pressure matrix + CASE ( 'C', 'S', 'I' ) ! TL calculation + ALLOCATE ( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) + IF ( iAllocStat/=0 ) THEN +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & + 'Insufficient memory for TL matrix: reduce Nr*NRz' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R IHOP_INIT' + END IF + U = 0.0 ! init default value + CASE ( 'A', 'a', 'R', 'E', 'e' ) ! Arrivals calculation + ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable + U( 1,1 ) = 0. ! init default value + CASE DEFAULT + ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable + U( 1,1 ) = 0. ! init default value + END SELECT + + ! for an arrivals run, allocate space for arrivals matrices + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'A', 'a', 'e' ) + ! allow space for at least MinNArr arrivals + MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & + MinNArr ) + ALLOCATE ( Arr( MaxNArr, Pos%NRr, NRz_per_range ), & + NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) + IF ( iAllocStat /= 0 ) THEN +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & + 'Not enough allocation for Arr; reduce ArrivalsStorage' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R IHOP_INIT' + END IF + CASE DEFAULT + MaxNArr = 1 + ALLOCATE ( Arr( 1, NRz_per_range, Pos%NRr ), & + NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) + END SELECT + + ! init Arr, Narr + ! Arr = something + NArr( 1:Pos%NRr, 1:NRz_per_range ) = 0 ! IEsco22 unnecessary? NArr = 0 below + +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(A)') + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) +#endif /* IHOP_WRITE_OUT */ + + + +! open all output files + IF ( IHOP_dumpfreq .GE. 0 ) & + CALL OpenOutputFiles( IHOP_fileroot, myTime, myIter, myThid ) + + ! Run Bellhop solver on a single processor + if (numberOfProcs.gt.1) then +! Use same single processID as IHOP COST package +! if(myProcId.eq.(numberOfProcs-1)) then + if(myProcId.eq.0) then + CALL CPU_TIME( Tstart ) + CALL BellhopCore(myThid) + CALL CPU_TIME( Tstop ) +! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. +!#ifdef ALLOW_COST +! ! Broadcast info to all MPI procs for COST function accumulation +! print *, "escobar: broacasting from pid ", myProcId +! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) +! +!#endif /* ALLOW_COST */ + endif + else + CALL CPU_TIME( Tstart ) + CALL BellhopCore(myThid) + CALL CPU_TIME( Tstop ) + endif + +#ifdef IHOP_WRITE_OUT + IF ( IHOP_dumpfreq.GE.0 ) THEN + ! print run time + if (numberOfProcs.gt.1) then + if(myProcId.ne.(numberOfProcs-1)) then + WRITE(msgBuf,'(A,I4,A)') 'NOTE: Proc ',myProcId, & + " didn't run ihop" + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + endif + endif + WRITE(msgBuf, '(A)' ) + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + WRITE(msgBuf, '(A,G15.3,A)' ) 'CPU Time = ', Tstop-Tstart, 's' + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + + ! close all files + IF ( IHOP_dumpfreq .GE. 0) THEN + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'C', 'S', 'I' ) ! TL calculation + CLOSE( SHDFile ) + CASE ( 'A', 'a' ) ! arrivals calculation + CLOSE( ARRFile ) + CASE ( 'R', 'E' ) ! ray and eigen ray trace + CLOSE( RAYFile ) + CASE ( 'e' ) + CLOSE( RAYFile ) + CLOSE( ARRFile ) + IF ( writeDelay ) CLOSE( DELFile ) + END SELECT + + if (numberOfProcs.gt.1) then + ! Erase prtfiles that aren't on procid = 0 + if(myProcId.ne.0) then + CLOSE(PRTFile, STATUS='DELETE') + else + CLOSE(PRTFile) + endif + else + CLOSE(PRTFile) + endif + ENDIF + ENDIF +#endif /* IHOP_WRITE_OUT */ + + RETURN + END !SUBROUTINE IHOP_INIT + + ! **********************************************************************! + SUBROUTINE BellhopCore( myThid ) + USE ssp_mod, only: iSegr !RG +! USE influence, only: ratio1, rB !RG + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + INTEGER :: IBPvec( 1 ), ibp, is, iBeamWindow2, Irz1, Irec, & + NalphaOpt + REAL (KIND=_RL90) :: Amp0, DalphaOpt, xs( 2 ), RadMax, s, & + c, cimag, gradc( 2 ), crr, crz, czz, rho + +!$TAF init BellhopCore1 = static, Pos%NSz +!$TAF init BellhopCore2 = static, Pos%NSz*Angles%Nalpha + + afreq = 2.0 * PI * IHOP_freq + + Angles%alpha = Angles%alpha * deg2rad ! convert to radians + Angles%Dalpha = 0.0 + IF ( Angles%Nalpha > 1 ) THEN + Angles%Dalpha = ( Angles%alpha( Angles%Nalpha ) - Angles%alpha( 1 ) ) & + / ( Angles%Nalpha - 1 ) ! angular spacing between beams + ELSE +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'BELLHOP BellhopCore: ', & + 'Required: Nalpha>1, else add iSingle_alpha(see angleMod)' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R BellhopCore' + END IF + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! begin solve ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SourceDepth: DO is = 1, Pos%NSz + +!$TAF store beam = BellhopCore1 +! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +! Scalar components +! Fixed arrays +!$TAF store ssp%z = BellhopCore1 +! Allocatable arrays +!$TAF store ssp%cmat,ssp%czmat = BellhopCore1 + + xs = [ zeroRL, Pos%Sz( is ) ] ! source coordinate, assuming source @ r=0 + + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'C','S','I' ) ! TL calculation, zero out pressure matrix + U = 0.0 + CASE ( 'A','a','e' ) ! Arrivals calculation, zero out arrival matrix + NArr = 0 + END SELECT + + CALL evalSSP( xs, c, cimag, gradc, crr, crz, czz, rho, myThid ) + + !!IESCO22: BEAM stuff !! + RadMax = 5 * c / IHOP_freq ! 5 wavelength max radius IEsco22: unused + IF ( Beam%RunType( 1:1 ) == 'C' ) THEN ! for Coherent TL Run + ! Are there enough rays? + DalphaOpt = SQRT( c / ( 6.0 * IHOP_freq * Pos%Rr( Pos%NRr ) ) ) + NalphaOpt = 2 + INT( ( Angles%alpha( Angles%Nalpha ) & + - Angles%alpha( 1 ) ) / DalphaOpt ) +#ifdef IHOP_WRITE_OUT + IF ( Angles%Nalpha < NalphaOpt ) THEN + WRITE( msgBuf, '(A,/,A,I10.4)' ) 'WARNING: Too few beams',& + 'Nalpha should be at least = ', NalphaOpt + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + ENDIF +#endif /* IHOP_WRITE_OUT */ + ENDIF + !!IESCO22: end BEAM stuff !! + + ! Trace successive beams + DeclinationAngle: DO ialpha = 1, Angles%Nalpha +!$TAF store arr,bdry,isegr,narr,u = BellhopCore2 +!!$TAF store ratio1,rb = BellhopCore2 +! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +! Scalar components +! Fixed arrays +! Allocatable arrays +!$TAF store ssp%cmat,ssp%czmat = BellhopCore2 + ! take-off declination angle in degrees + SrcDeclAngle = rad2deg * Angles%alpha( ialpha ) + + ! Single ray run? then don't visit code below + IF ( Angles%iSingle_alpha==0 .OR. ialpha==Angles%iSingle_alpha ) THEN + + !!IESCO22: BEAM stuff !! + IBPvec = maxloc( SrcBmPat( :, 1 ), mask = SrcBmPat( :, 1 ) & + < SrcDeclAngle ) ! index of ray angle in beam pattern + IBP = IBPvec( 1 ) + IBP = MAX( IBP, 1 ) ! don't go before beginning of table + IBP = MIN( IBP, NSBPPts - 1 ) ! don't go past end of table + ! IEsco22: When a beam pattern isn't specified, IBP = 1 + + ! linear interpolation to get amplitude + s = ( SrcDeclAngle - SrcBmPat( IBP, 1 ) ) & + / ( SrcBmPat( IBP + 1, 1 ) - SrcBmPat( IBP, 1 ) ) + Amp0 = ( 1 - s ) * SrcBmPat( IBP, 2 ) + s * SrcBmPat( IBP + 1, 2 ) + ! IEsco22: When a beam pattern isn't specified, Amp0 = 0 + + ! Lloyd mirror pattern for semi-coherent option + IF ( Beam%RunType( 1:1 ) == 'S' ) & + Amp0 = Amp0 * SQRT( 2.0 ) * ABS( SIN( afreq / c * xs( 2 ) & + * SIN( Angles%alpha( ialpha ) ) ) ) + !!IESCO22: end BEAM stuff !! + +#ifdef IHOP_WRITE_OUT + ! report progress in PRTFile (skipping some angles) + IF ( MOD( ialpha - 1, max( Angles%Nalpha / 50, 1 ) ) == 0 ) THEN + WRITE(msgBuf,'(A,I7,F10.2)') 'Tracing ray ', & + ialpha, SrcDeclAngle + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + FLUSH( PRTFile ) + END IF +#endif /* IHOP_WRITE_OUT */ + + ! Trace a ray, update ray2D structure + CALL TraceRay2D( xs, Angles%alpha( ialpha ), Amp0, myThid ) + + ! Write the ray trajectory to RAYFile + IF ( Beam%RunType(1:1) == 'R') THEN + CALL WriteRay2D( SrcDeclAngle, Beam%Nsteps ) + IF (writeDelay) CALL WriteDel2D( SrcDeclAngle, Beam%Nsteps ) + ELSE ! Compute the contribution to the field + SELECT CASE ( Beam%Type( 1:1 ) ) + CASE ( 'g' ) + CALL InfluenceGeoHatRayCen( U, Angles%alpha( ialpha ), & + Angles%Dalpha, myThid ) + CASE ( 'B' ) + CALL InfluenceGeoGaussianCart( U, Angles%alpha( ialpha ), & + Angles%Dalpha, myThid ) + CASE ( 'G','^' ) + CALL InfluenceGeoHatCart( U, Angles%alpha( ialpha ), & + Angles%Dalpha, myThid ) + CASE DEFAULT !IEsco22: thesis is in default behavior + CALL InfluenceGeoHatCart( U, Angles%alpha( ialpha ), & + Angles%Dalpha, myThid ) + END SELECT + END IF + + END IF + END DO DeclinationAngle + + ! write results to disk + + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'C', 'S', 'I' ) ! TL calculation + CALL ScalePressure( Angles%Dalpha, ray2D( 1 )%c, Pos%Rr, U, & + NRz_per_range, Pos%NRr, Beam%RunType, IHOP_freq ) + IRec = 10 + NRz_per_range * ( is - 1 ) + RcvrDepth: DO Irz1 = 1, NRz_per_range + IRec = IRec + 1 + WRITE( SHDFile, REC = IRec ) U( Irz1, 1:Pos%NRr ) + END DO RcvrDepth + CASE ( 'A', 'e' ) ! arrivals calculation, ascii + CALL WriteArrivalsASCII( Pos%Rr, NRz_per_range, Pos%NRr, & + Beam%RunType( 4:4 ) ) + CASE ( 'a' ) ! arrivals calculation, binary + CALL WriteArrivalsBinary( Pos%Rr, NRz_per_range, Pos%NRr, & + Beam%RunType( 4:4 ) ) + END SELECT + + END DO SourceDepth + + RETURN + END !SUBROUTINE BellhopCore + + ! **********************************************************************! + + SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) + + ! Traces the beam corresponding to a particular take-off angle, alpha [rad] + + USE ihop_mod, only: MaxN, istep + USE step, only: Step2D + USE ssp_mod, only: iSegr !RG + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + REAL (KIND=_RL90), INTENT( IN ) :: xs(2) ! coordinate of source + REAL (KIND=_RL90), INTENT( IN ) :: alpha, Amp0 ! angle in rad, beam amp + INTEGER :: is, is1 ! indices for ray step + REAL (KIND=_RL90) :: c, cimag, gradc(2), crr, crz, czz, rho + REAL (KIND=_RL90) :: dEndTop(2), dEndBot(2), TopnInt(2), BotnInt(2), & + ToptInt(2), BottInt(2), rayt(2), raytOld(2) + ! Distances from ray beginning, end to top and bottom + REAL (KIND=_RL90) :: DistBegTop, DistEndTop, DistBegBot, DistEndBot + REAL (KIND=_RL90) :: sss, declAlpha, declAlphaOld + LOGICAL :: RayTurn = .FALSE., continue_steps + +!$TAF init TraceRay2D = static, MaxN-1 + + ! Initial conditions (IC) + iSmallStepCtr = 0 + CALL evalSSP( xs, c, cimag, gradc, crr, crz, czz, rho, myThid ) + ray2D( 1 )%c = c ! sound speed at source [m/s] + ray2D( 1 )%x = xs ! range and depth of source + ray2D( 1 )%t = [ COS( alpha ), SIN( alpha ) ] / c ! unit tangent / c + ray2D( 1 )%p = [ 1.0, 0.0 ] ! IESCO22: slowness vector + ! second component of qv is not supported in geometric beam tracing + ! set I.C. to 0 in hopes of saving run time + IF ( Beam%RunType( 2:2 ) == 'G' .or. Beam%RunType( 2:2 ) == 'B') THEN + ray2D( 1 )%q = [ 0.0, 0.0 ] ! IESCO22: geometric beam in Cartesian + ELSE + ray2D( 1 )%q = [ 0.0, 1.0 ] ! IESCO22: ray centered coords + END IF + ray2D( 1 )%tau = 0.0 + ray2D( 1 )%Amp = Amp0 + ray2D( 1 )%Phase = 0.0 + ray2D( 1 )%NumTopBnc = 0 + ray2D( 1 )%NumBotBnc = 0 + ray2D( 1 )%NumTurnPt = 0 + + ! IESCO22: update IsegTop, rTopSeg and IsegBot, rBotSeg in bdrymod.f90 + CALL GetTopSeg( xs(1), myThid ) ! find alimetry segment above the source + CALL GetBotSeg( xs(1), myThid ) ! find bathymetry segment below the source + + ! IESCO22: 'L' is long format. See BeadBTY s/r in bdrymod.f90. Default is to + ! calculate cp, cs, and rho instead of reading them in + IF ( atiType( 2 : 2 ) == 'L' ) THEN + ! grab the geoacoustic info for the new segment + Bdry%Top%HS%cp = Top( IsegTop )%HS%cp + Bdry%Top%HS%cs = Top( IsegTop )%HS%cs + Bdry%Top%HS%rho = Top( IsegTop )%HS%rho + END IF + IF ( btyType( 2 : 2 ) == 'L' ) THEN + Bdry%Bot%HS%cp = Bot( IsegBot )%HS%cp + Bdry%Bot%HS%cs = Bot( IsegBot )%HS%cs + Bdry%Bot%HS%rho = Bot( IsegBot )%HS%rho + END IF + + CALL Distances2D( ray2D( 1 )%x, Top( IsegTop )%x, Bot( IsegBot )%x, & + dEndTop, dEndBot, & + Top( IsegTop )%n, Bot( IsegBot )%n, & + DistBegTop, DistBegBot ) + + IF ( DistBegTop <= 0 .OR. DistBegBot <= 0 ) THEN + Beam%Nsteps = 1 +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(A)') & + 'WARNING: TraceRay2D: The source is outside the domain boundaries' + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) +#endif /* IHOP_WRITE_OUT */ + RETURN ! source must be within the domain + END IF + + + ! Trace the beam (Reflect2D increments the step index, is) + is = 0 + continue_steps = .true. + Stepping: DO istep = 1, MaxN - 1 +!$TAF store bdry,beam,continue_steps,distbegbot,distbegtop = TraceRay2D +!$TAF store isegbot,isegtop,ray2d,rbotseg,rtopseg = TraceRay2D +! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +! Scalar components +! Fixed arrays +! Allocatable arrays +!$TAF store ssp%cmat,ssp%czmat = TraceRay2D + IF ( continue_steps ) THEN +!$TAF store is = TraceRay2D + is = is + 1 ! old step + is1 = is + 1 ! new step forward + + CALL Step2D( ray2D( is ), ray2D( is1 ), & + Top( IsegTop )%x, Top( IsegTop )%n, & + Bot( IsegBot )%x, Bot( IsegBot )%n, myThid ) + + ! IESCO22: turning point check + IF ( is > 1 ) THEN + rayt = ray2D(is1)%x - ray2D(is)%x + raytOld = ray2D(is)%x - ray2D(is-1)%x + declAlpha = ATAN2( rayt(2), rayt(1) ) + declAlphaOld = ATAN2( raytOld(2), raytOld(1) ) + RayTurn = ( declAlpha <= 0.0d0 .AND. declAlphaOld > 0.0d0 .OR. & + declAlpha >= 0.0d0 .AND. declAlphaOld < 0.0d0 ) + IF ( RayTurn) THEN + ray2D( is1 )%NumTurnPt = ray2D( is )%NumTurnPt + 1 + END IF + END IF + + ! New altimetry segment? + IF ( ray2D( is1 )%x( 1 ) < rTopSeg( 1 ) .OR. & + ray2D( is1 )%x( 1 ) > rTopSeg( 2 ) ) THEN + CALL GetTopSeg( ray2D( is1 )%x( 1 ), myThid ) + IF ( atiType( 2 : 2 ) == 'L' ) THEN + ! ATIFile geoacoustic info from new segment, cp + Bdry%Top%HS%cp = Top( IsegTop )%HS%cp + Bdry%Top%HS%cs = Top( IsegTop )%HS%cs + Bdry%Top%HS%rho = Top( IsegTop )%HS%rho + END IF + END IF + + ! New bathymetry segment? + IF ( ray2D( is1 )%x( 1 ) < rBotSeg( 1 ) .OR. & + ray2D( is1 )%x( 1 ) > rBotSeg( 2 ) ) THEN + CALL GetBotSeg( ray2D( is1 )%x( 1 ), myThid ) + IF ( btyType( 2 : 2 ) == 'L' ) THEN + ! BTYFile geoacoustic info from new segment, cp + Bdry%Bot%HS%cp = Bot( IsegBot )%HS%cp + Bdry%Bot%HS%cs = Bot( IsegBot )%HS%cs + Bdry%Bot%HS%rho = Bot( IsegBot )%HS%rho + END IF + END IF + + ! *** Reflections *** + ! Tests ray at step is IS inside, and ray at step is+1 IS outside + ! DistBeg is the distance at step is, which is saved + ! DistEnd is the distance at step is+1, which needs to be calculated + + CALL Distances2D( ray2D( is1 )%x, & + Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & + Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) + + ! IESCO22: Did new ray point cross top boundary? Then reflect + IF ( DistBegTop > 0.0d0 .AND. DistEndTop <= 0.0d0 ) THEN + + IF ( atiType == 'C' ) THEN ! curvilinear interpolation + ! proportional distance along segment + sss = DOT_PRODUCT( dEndTop, Top( IsegTop )%t ) & + / Top( IsegTop )%Len + ToptInt = ( 1-sss ) * Top( IsegTop )%Nodet & + + sss * Top( 1+IsegTop )%Nodet + TopnInt = ( 1-sss ) * Top( IsegTop )%Noden & + + sss * Top( 1+IsegTop )%Noden + ELSE + TopnInt = Top( IsegTop )%n ! normal is constant in a segment + ToptInt = Top( IsegTop )%t + END IF + + CALL Reflect2D( is, Bdry%Top%HS, 'TOP', ToptInt, TopnInt, & + Top( IsegTop )%kappa, RTop, NTopPTS, & + myThid ) + + CALL Distances2D( ray2D( is+1 )%x, & + Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & + Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) + + ! IESCO22: Did ray cross bottom boundary? Then reflect + ELSE IF ( DistBegBot > 0.0d0 .AND. DistEndBot <= 0.0d0 ) THEN + + IF ( btyType == 'C' ) THEN ! curvilinear interpolation + ! proportional distance along segment + sss = DOT_PRODUCT( dEndBot, Bot( IsegBot )%t ) & + / Bot( IsegBot )%Len + BotnInt = ( 1-sss ) * Bot( IsegBot )%Noden & + + sss * Bot( 1+IsegBot )%Noden + BottInt = ( 1-sss ) * Bot( IsegBot )%Nodet & + + sss * Bot( 1+IsegBot )%Nodet + ELSE + BotnInt = Bot( IsegBot )%n ! normal is constant in a segment + BottInt = Bot( IsegBot )%t + END IF + + CALL Reflect2D( is, Bdry%Bot%HS, 'BOT', BottInt, BotnInt, & + Bot( IsegBot )%kappa, RBot, NBotPTS, & + myThid ) + + CALL Distances2D( ray2D( is+1 )%x, & + Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & + Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) + END IF + + ! Has the ray left the box, lost its energy, escaped the boundaries, + ! or exceeded storage limit? + ! IESCO22: Rewriting for debugging with gcov + WRITE(msgBuf,'(A)') ' ' + IF ( ray2D( is+1 )%x( 1 ) > Beam%Box%r ) THEN + WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box%r' + ELSE IF ( ray2D( is+1 )%x( 1 ) < 0 ) THEN + WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box r=0' + ELSE IF ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) THEN + WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box%z' + ELSE IF ( ABS( ray2D( is+1 )%Amp ) < 0.005 ) THEN + WRITE(msgBuf,'(A)') 'TraceRay2D: ray lost energy' + ELSE IF ( DistBegTop < 0.0 .AND. DistEndTop < 0.0 ) THEN + WRITE(msgBuf,'(A)') 'TraceRay2D: ray escaped top bound' + ELSE IF ( DistBegBot < 0.0 .AND. DistEndBot < 0.0 ) THEN + WRITE(msgBuf,'(A)') 'TraceRay2D: ray escaped bot bound' + ELSE IF ( is >= MaxN - 3 ) THEN + WRITE(msgBuf,'(2A)') 'WARNING: TraceRay2D: Check storage ',& + 'for ray trajectory' + END IF + +#ifdef IHOP_WRITE_OUT + IF ( ( ray2D( is+1 )%x( 1 ) > Beam%Box%r ) .OR. & + ( ray2D( is+1 )%x( 1 ) < 0 ) .OR. & + ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) .OR. & + ( ABS( ray2D( is+1 )%Amp ) < 0.005 ) .OR. & + ( DistBegTop < 0.0 .AND. DistEndTop < 0.0 ) .OR. & + ( DistBegBot < 0.0 .AND. DistEndBot < 0.0 ) .OR. & + ( is >= MaxN - 3 ) ) THEN + IF ( IHOP_dumpfreq .GE. 0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + ENDIF +#endif /* IHOP_WRITE_OUT */ + IF (INDEX(msgBuf, 'TraceRay2D').eq.1) THEN + Beam%Nsteps = is+1 + continue_steps = .false. + ELSE IF (INDEX(msgBuf, 'WARNING: TraceRay2D').eq.1) THEN + Beam%Nsteps = is + continue_steps = .false. + END IF + + DistBegTop = DistEndTop + DistBegBot = DistEndBot + END IF ! continue_steps + END DO Stepping + + RETURN + END !SUBROUTINE TraceRay2D + + ! **********************************************************************! + + SUBROUTINE Distances2D( rayx, Topx, Botx, dTop, dBot, Topn, Botn, DistTop, & + DistBot ) + + ! Calculates the distances to the boundaries + ! Formula differs from JKPS because code applies outward pointing normals + + REAL (KIND=_RL90), INTENT( IN ) :: rayx(2) ! ray coordinate + REAL (KIND=_RL90), INTENT( IN ) :: Topx(2), Botx(2) ! top, bottom coordinate + REAL (KIND=_RL90), INTENT( IN ) :: Topn(2), Botn(2) ! top, bottom normal vector (outward) + REAL (KIND=_RL90), INTENT( OUT ) :: dTop(2), dBot(2) ! vector pointing from top, bottom bdry to ray + REAL (KIND=_RL90), INTENT( OUT ) :: DistTop, DistBot ! distance (normal to bdry) from the ray to top, bottom boundary + + dTop = rayx - Topx ! vector pointing from top to ray + dBot = rayx - Botx ! vector pointing from bottom to ray + DistTop = -DOT_PRODUCT( Topn, dTop ) + DistBot = -DOT_PRODUCT( Botn, dBot ) + + RETURN + END !SUBROUTINE Distances2D + + ! **********************************************************************! + + SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) + USE bdry_mod, only: HSInfo + USE refCoef, only: ReflectionCoef + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + INTEGER, INTENT( IN ) :: Npts ! unsued if there are no refcoef files + REAL (KIND=_RL90), INTENT( IN ) :: tBdry(2), nBdry(2) ! Tangent and normal to the boundary + REAL (KIND=_RL90), INTENT( IN ) :: kappa ! Boundary curvature, for curvilinear grids + CHARACTER (LEN=3), INTENT( IN ) :: BotTop ! bottom or top reflection + TYPE( HSInfo ), INTENT( IN ) :: HS ! half-space properties + TYPE(ReflectionCoef), INTENT( IN ) :: RefC( NPts ) ! reflection coefficient + INTEGER, INTENT( INOUT ) :: is + INTEGER :: is1 + REAL (KIND=_RL90) :: c, cimag, gradc( 2 ), crr, crz, czz, & + rho ! derivatives of sound speed + REAL (KIND=_RL90) :: RM, RN, Tg, Th, rayt( 2 ), rayn( 2 ), & + rayt_tilde( 2 ), rayn_tilde( 2 ), cnjump, & + csjump ! for curvature change + REAL (KIND=_RL90) :: ck, co, si, cco, ssi, pdelta, rddelta, sddelta, & + theta_bot ! for beam shift + COMPLEX (KIND=_RL90) :: kx, kz, kzP, kzS, kzP2, kzS2, mu, f, g, y2, y4, & + Refl ! for tabulated reflection coef. + COMPLEX (KIND=_RL90) :: ch, a, b, d, sb, delta, ddelta ! for beam shift + TYPE(ReflectionCoef) :: RInt + +!$TAF init reflect2d1 = 'bellhopreflectray2d' + + ! Init default values for local derived type Rint + Rint%R = 0.0 + Rint%phi = 0.0 + Rint%theta = -999.0 + + ! increment stepping counters + is = is + 1 ! old step + is1 = is + 1 ! new step reflected (same x, updated basis vectors) + + Tg = DOT_PRODUCT( ray2D( is )%t, tBdry ) ! ray tan projected along boundary + Th = DOT_PRODUCT( ray2D( is )%t, nBdry ) ! ray tan projected normal boundary + + ray2D( is1 )%NumTopBnc = ray2D( is )%NumTopBnc + ray2D( is1 )%NumBotBnc = ray2D( is )%NumBotBnc + ray2D( is1 )%x = ray2D( is )%x + ray2D( is1 )%t = ray2D( is )%t - 2.0 * Th * nBdry ! change ray direction + + ! Calculate change in curvature, kappa + ! Based on formulas given by Muller, Geoph. J. R.A.S., 79 (1984). + + ! Get c + CALL evalSSP( ray2D( is )%x, c, cimag, gradc, crr, crz, czz, rho, myThid ) + + ! unmodified unit ray tangent and normal + rayt = c * ray2D( is )%t ! unit tangent to ray + rayn = [ -rayt( 2 ), rayt( 1 ) ] ! unit normal to ray + + ! reflected unit ray tangent and normal + rayt_tilde = c * ray2D( is1 )%t ! unit tangent to ray + rayn_tilde = -[ -rayt_tilde( 2 ), rayt_tilde( 1 ) ] ! unit normal to ray + + ! get the jumps (this could be simplified, e.g. jump in rayt is + ! roughly 2 * Th * nbdry + cnjump = -DOT_PRODUCT( gradc, rayn_tilde - rayn ) + csjump = -DOT_PRODUCT( gradc, rayt_tilde - rayt ) + RN = 2 * kappa / c ** 2 / Th ! boundary curvature correction + + IF ( BotTop == 'TOP' ) THEN + ! cnjump changes sign because the (t,n) system of the top boundary has a + ! different sense to the bottom boundary + cnjump = -cnjump + RN = -RN + END IF + + RM = Tg / Th ! this is tan( alpha ) where alpha is the angle of incidence + RN = RN + RM * ( 2 * cnjump - RM * csjump ) / c ** 2 + + SELECT CASE ( Beam%Type( 3 : 3 ) ) + CASE ( 'D' ) + RN = 2.0 * RN + CASE ( 'Z' ) + RN = 0.0 + END SELECT + + ray2D( is1 )%c = c + ray2D( is1 )%tau = ray2D( is )%tau + ray2D( is1 )%p = ray2D( is )%p + ray2D( is )%q * RN + ray2D( is1 )%q = ray2D( is )%q + + ! account for phase change + + + SELECT CASE ( HS%BC ) + CASE ( 'R' ) ! rigid + ray2D( is1 )%Amp = ray2D( is )%Amp + ray2D( is1 )%Phase = ray2D( is )%Phase + CASE ( 'V' ) ! vacuum + ray2D( is1 )%Amp = ray2D( is )%Amp + ray2D( is1 )%Phase = ray2D( is )%Phase + PI + CASE ( 'F' ) ! file +!$TAF store rint = reflect2d1 + RInt%theta = rad2deg * ABS( ATAN2( Th, Tg ) ) ! angle of incidence (relative to normal to bathymetry) + IF ( RInt%theta > 90 ) RInt%theta = 180. - RInt%theta ! reflection coefficient is symmetric about 90 degrees + CALL InterpolateReflectionCoefficient( RInt, RefC, Npts ) + ray2D( is1 )%Amp = ray2D( is )%Amp * RInt%R + ray2D( is1 )%Phase = ray2D( is )%Phase + RInt%phi + CASE ( 'A', 'G' ) ! half-space + kx = afreq * Tg ! wavenumber in direction parallel to bathymetry + kz = afreq * Th ! wavenumber in direction perpendicular to bathymetry + + ! notation below is a bit mis-leading + ! kzS, kzP is really what I called gamma in other codes, and differs by a + ! factor of +/- i + IF ( REAL( HS%cS ) > 0.0 ) THEN + kzS2 = kx**2 - ( afreq / HS%cS )**2 + kzP2 = kx**2 - ( afreq / HS%cP )**2 + kzS = SQRT( kzS2 ) + kzP = SQRT( kzP2 ) + mu = HS%rho * HS%cS**2 + + y2 = ( ( kzS2 + kx**2 )**2 - 4.0D0 * kzS * kzP * kx**2 ) * mu + y4 = kzP * ( kx**2 - kzS2 ) + + f = afreq**2 * y4 + g = y2 + ELSE + kzP = SQRT( kx**2 - ( afreq / HS%cP )**2 ) + + ! Intel and GFortran compilers return different branches of the SQRT + ! for negative reals + IF ( REAL( kzP ) == 0.0D0 .AND. AIMAG( kzP ) < 0.0D0 ) kzP = -kzP + f = kzP + g = HS%rho + ENDIF + + ! complex reflection coef. + Refl = - ( rho*f - i * kz*g ) / ( rho*f + i*kz*g ) + + IF ( ABS( Refl ) < 1.0E-5 ) THEN ! kill a ray that has lost its energy in reflection + ray2D( is1 )%Amp = 0.0 + ray2D( is1 )%Phase = ray2D( is )%Phase + ELSE + ray2D( is1 )%Amp = ABS( Refl ) * ray2D( is )%Amp + ray2D( is1 )%Phase = ray2D( is )%Phase + & + ATAN2( AIMAG( Refl ), REAL( Refl ) ) + + if ( Beam%Type( 4:4 ) == 'S' ) then ! beam displacement & width change (Seongil's version) + ch = ray2D( is )%c / conjg( HS%cP ) + co = ray2D( is )%t( 1 ) * ray2D( is )%c + si = ray2D( is )%t( 2 ) * ray2D( is )%c + ck = afreq / ray2D( is )%c + + a = 2 * HS%rho * ( 1 - ch * ch ) + b = co * co - ch * ch + d = HS%rho * HS%rho * si * si + b + sb = sqrt( b ) + cco = co * co + ssi = si * si + + IF ( si /= 0.0 ) THEN + delta = a * co / si / ( ck * sb * d ) ! Do we need an abs() on this??? + ELSE + delta = 0.0 + END IF + + pdelta = real( delta ) / ( ray2D( is )%c / co) + ddelta = -a / ( ck*sb*d ) - a*cco / ssi / (ck*sb*d) & + + a*cco / (ck*b*sb*d) & + -a*co / si / (ck*sb*d*d) & + * (2* HS%rho * HS%rho *si*co-2*co*si) + rddelta = -real( ddelta ) + sddelta = rddelta / abs( rddelta ) + + ! next 3 lines have an update by Diana McCammon to allow a sloping + ! bottom . I think the formulas are good, but this won't be reliable + ! because it doesn't have the logic that tracks crossing into new + ! segments after the ray displacement. + + theta_bot = datan( tBdry( 2 ) / tBdry( 1 )) ! bottom angle + ray2D( is1 )%x( 1 ) = ray2D( is1 )%x( 1 ) + real( delta ) & + * dcos( theta_bot ) ! range displacement + ray2D( is1 )%x( 2 ) = ray2D( is1 )%x( 2 ) + real( delta ) & + * dsin( theta_bot ) ! depth displacement + ray2D( is1 )%tau = ray2D( is1 )%tau + pdelta ! phase change + ray2D( is1 )%q = ray2D( is1 )%q + sddelta * rddelta * si * c & + * ray2D( is )%p ! beam-width change + endif + + ENDIF + + CASE DEFAULT +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'HS%BC = ', HS%BC + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + WRITE(msgBuf,'(A)') 'BELLHOP Reflect2D: Unknown boundary condition type' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R Reflect2D' + END SELECT + + ! Update top/bottom bounce counter + IF (BotTop == 'TOP') THEN + ray2D( is+1 )%NumTopBnc = ray2D( is )%NumTopBnc + 1 + ELSE IF ( BotTop == 'BOT' ) THEN + ray2D( is+1 )%NumBotBnc = ray2D( is )%NumBotBnc + 1 + ELSE +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'BELLHOP Reflect2D: ', & + 'no reflection bounce, but in relfect2d somehow' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R Reflect2D' + END IF + + RETURN + END !SUBROUTINE Reflect2D + +END MODULE initenv_mod From 9f4fefdcd4786c33408aebf1f98d37ee8500a766 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Wed, 11 Sep 2024 16:12:00 -0500 Subject: [PATCH 02/13] remove more local only vars --- src/angle_mod.F90 | 3 ++- src/ihop_mod.F90 | 2 +- src/initenvihop.F90 | 28 ++++++++++++++++++---------- src/srpos_mod.F90 | 2 +- 4 files changed, 22 insertions(+), 13 deletions(-) diff --git a/src/angle_mod.F90 b/src/angle_mod.F90 index 24901cb..07e53ce 100644 --- a/src/angle_mod.F90 +++ b/src/angle_mod.F90 @@ -8,7 +8,7 @@ MODULE angle_mod USE ihop_mod, only: PRTFile USE subTab_mod, only: SubTab - USE srPos_mod, only: Pos, Number_to_Echo + USE srPos_mod, only: Pos USE sort_mod, only: Sort ! ! USES @@ -32,6 +32,7 @@ MODULE angle_mod !======================================================================= + INTEGER, PARAMETER :: Number_to_Echo = 10 INTEGER :: ialpha #ifdef IHOP_THREED INTEGER :: ibeta diff --git a/src/ihop_mod.F90 b/src/ihop_mod.F90 index 7d8253c..dfa1eb3 100644 --- a/src/ihop_mod.F90 +++ b/src/ihop_mod.F90 @@ -28,7 +28,7 @@ MODULE ihop_mod PRTFile, RAYFile, DELFile, SHDFile, ARRFile, SSPFile,& ATIFile, BTYFile, BRCFile, TRCFile, IRCFile, SBPFile,& MaxN, Nrz_per_range, iStep, afreq, SrcDeclAngle, & - Title, Beam, ray2D, ray2DPt, iSmallStepCtr + Title, Beam, ray2D, ray2DPt, iSmallStepCtr, rxyz !======================================================================= diff --git a/src/initenvihop.F90 b/src/initenvihop.F90 index e3a14d9..8686398 100644 --- a/src/initenvihop.F90 +++ b/src/initenvihop.F90 @@ -760,6 +760,17 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) REAL (KIND=_RL90) :: Mz, vr, alpha2_f ! values related to grain size REAL (KIND=_RL90) :: ztemp, bPower, fT + ! ****** Read in BC parameters depending on particular choice ****** + HS%cp = 0.0 + HS%cs = 0.0 + HS%rho = 0.0 + + ! RG recommends resetting to the default values from ssp_mod.F90 + bPower = 1.0 + fT = 1D20 + rhoR = 1.0 + + ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN ! Echo to PRTFile user's choice of boundary condition @@ -810,16 +821,6 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) END SELECT ENDIF ! no output on adjoint runs - ! ****** Read in BC parameters depending on particular choice ****** - HS%cp = 0.0 - HS%cs = 0.0 - HS%rho = 0.0 - - ! RG recommends resetting to the default values from ssp_mod.F90 - bPower = 1.0 - fT = 1D20 - rhoR = 1.0 - SELECT CASE ( HS%BC ) CASE ( 'A' ) ! *** Half-space properties *** ! IEsco23: MISSING IF BOTTOM BC CHECK @@ -909,6 +910,13 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) IF (IHOP_dumpfreq.GE.0) & CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) #endif /* IHOP_WRITE_OUT */ + CASE DEFAULT +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'INITENVIHOP TopBot: ', & + 'Unknown boundary condition type' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R TopBot' END SELECT RETURN diff --git a/src/srpos_mod.F90 b/src/srpos_mod.F90 index 1d3401f..2eb9855 100644 --- a/src/srpos_mod.F90 +++ b/src/srpos_mod.F90 @@ -26,7 +26,7 @@ MODULE srpos_mod ! public interfaces !======================================================================= - public Pos, Number_to_Echo, Nfreq, freqVec, ReadSxSy, ReadSzRz, & + public Pos, Nfreq, freqVec, ReadSxSy, ReadSzRz, & ReadRcvrRanges, ReadFreqVec #ifdef IHOP_THREED public ReadRcvrBearings From e75748bfc437f440395690968957890d8cd82beb Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Thu, 12 Sep 2024 15:52:15 -0500 Subject: [PATCH 03/13] only with ALLOW_COST --- src/active_file_control_ihop_cost.F | 24 +- src/active_file_ihop_cost.F | 24 +- src/active_file_ihop_cost_ad.F | 24 +- src/cost_ihop.F | 10 +- src/ihop_cost_init_equifiles.F | 4 +- src/ihop_cost_inloop.F | 6 +- src/ihop_cost_modval.F | 4 +- src/ihop_cost_read_obs.F | 6 +- src/ihop_init_fixed_env.F90 | 1382 +++++++++++---------------- src/ihop_readparms.F | 2 + 10 files changed, 629 insertions(+), 857 deletions(-) diff --git a/src/active_file_control_ihop_cost.F b/src/active_file_control_ihop_cost.F index 8bd0f71..1a6ccb9 100644 --- a/src/active_file_control_ihop_cost.F +++ b/src/active_file_control_ihop_cost.F @@ -36,7 +36,9 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE_RL( #ifdef ALLOW_IHOP # include "netcdf.inc" # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -51,7 +53,7 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE_RL( CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) C !LOCAL VARIABLES: integer err, varid1, varid2 integer vec_start, vec_count @@ -225,7 +227,9 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE_RL( #ifdef ALLOW_IHOP # include "netcdf.inc" # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -238,7 +242,7 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE_RL( _RL active_var CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) C !LOCAL VARIABLES: integer err, varid1, varid2, varid3 integer vec_start, vec_count @@ -369,7 +373,9 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB_RL( #ifdef ALLOW_IHOP # include "netcdf.inc" # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -384,7 +390,7 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB_RL( CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) C !LOCAL VARIABLES: integer err, varid1, varid2 integer vec_start, vec_count @@ -496,7 +502,9 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB_RL( #ifdef ALLOW_IHOP # include "netcdf.inc" # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -509,7 +517,7 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB_RL( _RL active_var CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) C !LOCAL VARIABLES: integer err, varid1, varid2 integer vec_start, vec_count diff --git a/src/active_file_ihop_cost.F b/src/active_file_ihop_cost.F index e6bfd5a..3648be7 100644 --- a/src/active_file_ihop_cost.F +++ b/src/active_file_ihop_cost.F @@ -34,7 +34,9 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -54,7 +56,7 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE( _RL dummy CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_read_ihop_tile_rl( fidfwd_obs(active_num_file,bi,bj), & active_num_file, @@ -95,7 +97,9 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -112,7 +116,7 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE( _RL dummy CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_write_ihop_tile_rl( fidfwd_obs(active_num_file,bi,bj), & active_num_file, @@ -153,7 +157,9 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -173,7 +179,7 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB( _RL dummy CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_read_ihop_glob_rl( & fidglobal(active_num_file), @@ -213,7 +219,9 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -230,7 +238,7 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB( _RL dummy CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_write_ihop_glob_rl( & fidglobal(active_num_file), diff --git a/src/active_file_ihop_cost_ad.F b/src/active_file_ihop_cost_ad.F index a373d85..f2c7f49 100644 --- a/src/active_file_ihop_cost_ad.F +++ b/src/active_file_ihop_cost_ad.F @@ -31,7 +31,9 @@ SUBROUTINE ADACTIVE_READ_IHOP_TILE( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -50,7 +52,7 @@ SUBROUTINE ADACTIVE_READ_IHOP_TILE( LOGICAL lAdInit CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_read_ihop_tile_rl( fidadj_obs(active_num_file,bi,bj), & active_num_file, @@ -88,7 +90,9 @@ SUBROUTINE ADACTIVE_WRITE_IHOP_TILE( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -107,7 +111,7 @@ SUBROUTINE ADACTIVE_WRITE_IHOP_TILE( _RL dummy CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_write_ihop_tile_rl( fidadj_obs(active_num_file,bi,bj), & active_num_file, @@ -145,7 +149,9 @@ SUBROUTINE ADACTIVE_READ_IHOP_GLOB( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -164,7 +170,7 @@ SUBROUTINE ADACTIVE_READ_IHOP_GLOB( LOGICAL lAdInit CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_read_ihop_glob_rl( fidadglobal(active_num_file), & active_num_file, @@ -201,7 +207,9 @@ SUBROUTINE ADACTIVE_WRITE_IHOP_GLOB( #include "SIZE.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT PARAMETERS: @@ -220,7 +228,7 @@ SUBROUTINE ADACTIVE_WRITE_IHOP_GLOB( _RL dummy CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) CALL active_write_ihop_glob_rl( fidadglobal(active_num_file), & active_num_file, diff --git a/src/cost_ihop.F b/src/cost_ihop.F index 7b36726..09647c6 100644 --- a/src/cost_ihop.F +++ b/src/cost_ihop.F @@ -73,15 +73,17 @@ SUBROUTINE COST_IHOP( logical exst _RL objf_ihop_glo _RL num_ihop_glo - _RL ihopObs_buff(NOBSMAX_IHOP) - _RL samples_mask_buff(NOBSMAX_IHOP) - _RL ihopObs_modval_glob(NOBSMAX_IHOP) - _RL samples_mask_glob(NOBSMAX_IHOP) _RL tmpgs INTEGER tmpgsi INTEGER ObsNo2,fid,dimid INTEGER nmodmean, nobsmean _RL offset, mod_mean, ihop_mean +#ifdef ALLOW_COST + _RL ihopObs_buff(NOBSMAX_IHOP) + _RL samples_mask_buff(NOBSMAX_IHOP) + _RL ihopObs_modval_glob(NOBSMAX_IHOP) + _RL samples_mask_glob(NOBSMAX_IHOP) +#endif C !FUNCTIONS INTEGER ILNBLNK diff --git a/src/ihop_cost_init_equifiles.F b/src/ihop_cost_init_equifiles.F index fba6708..22393b4 100644 --- a/src/ihop_cost_init_equifiles.F +++ b/src/ihop_cost_init_equifiles.F @@ -27,8 +27,10 @@ SUBROUTINE IHOP_COST_INIT_EQUIFILES( #include "DYNVARS.h" #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" # include "netcdf.inc" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif CEOP diff --git a/src/ihop_cost_inloop.F b/src/ihop_cost_inloop.F index 4f5dd41..cc0c6a8 100644 --- a/src/ihop_cost_inloop.F +++ b/src/ihop_cost_inloop.F @@ -32,8 +32,10 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) #endif #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" # include "netcdf.inc" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif #ifdef ALLOW_AUTODIFF # include "tamc.h" @@ -71,6 +73,7 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) ! itdkey = bi + (bj - 1)*nSx + (ikey_dynamics - 1)*nSx*nSy #endif +#ifdef ALLOW_COST _BEGIN_MASTER( myThid ) DO bj=1,nSy @@ -109,6 +112,7 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) _END_MASTER( myThid ) +#endif /* ALLOW_COST */ #endif RETURN diff --git a/src/ihop_cost_modval.F b/src/ihop_cost_modval.F index bcc7d21..0a44c94 100644 --- a/src/ihop_cost_modval.F +++ b/src/ihop_cost_modval.F @@ -39,8 +39,10 @@ SUBROUTINE IHOP_COST_MODVAL( #endif #ifdef ALLOW_IHOP # include "IHOP_SIZE.h" -# include "IHOP_COST.h" # include "netcdf.inc" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif #ifdef ALLOW_AUTODIFF # include "tamc.h" diff --git a/src/ihop_cost_read_obs.F b/src/ihop_cost_read_obs.F index 57a8560..c8cd12c 100644 --- a/src/ihop_cost_read_obs.F +++ b/src/ihop_cost_read_obs.F @@ -29,7 +29,9 @@ SUBROUTINE IHOP_COST_READ_OBS( # include "netcdf.inc" # include "IHOP_SIZE.h" # include "IHOP.h" -# include "IHOP_COST.h" +# ifdef ALLOW_COST +# include "IHOP_COST.h" +# endif #endif C !INPUT/OUTPUT PARAMETERS: @@ -42,7 +44,7 @@ SUBROUTINE IHOP_COST_READ_OBS( _RL vec_loc CEOP -#ifdef ALLOW_IHOP +#if (defined ALLOW_IHOP) && (defined ALLOW_COST) C !LOCAL VARIABLES: c tmpObsNo :: number of obs in the file diff --git a/src/ihop_init_fixed_env.F90 b/src/ihop_init_fixed_env.F90 index ffacb3b..aaec812 100644 --- a/src/ihop_init_fixed_env.F90 +++ b/src/ihop_init_fixed_env.F90 @@ -1,67 +1,46 @@ #include "IHOP_OPTIONS.h" -!BOP -! !ROUTINE: ihop_init_fixed_env -! !INTERFACE: - - USE ihop_mod, only: rad2deg, i, Beam, ray2D, NRz_per_range, afreq, & - SrcDeclAngle, iSmallStepCtr, & - PRTFile, SHDFile, ARRFile, RAYFile, DELFile - USE initenvihop, only: initEnv, openOutputFiles, resetMemory - USE angle_mod, only: Angles, ialpha - USE srPos_mod, only: Pos - USE ssp_mod, only: evalSSP, SSP - !HSInfo, Bdry, - USE bdry_mod, only: initATI, initBTY, GetTopSeg, GetBotSeg, Bot, Top, & - atiType, btyType, IsegTop, IsegBot, & - rTopSeg, rBotSeg, Bdry - USE refCoef, only: readReflectionCoefficient, & - InterpolateReflectionCoefficient, & - RTop, RBot, NBotPts, NTopPts - USE influence, only: InfluenceGeoHatRayCen, & - InfluenceGeoGaussianCart, InfluenceGeoHatCart, & - ScalePressure - USE beamPattern - USE writeRay, only: WriteRay2D, WriteDel2D - USE arr_mod, only: WriteArrivalsASCII,WriteArrivalsBinary,MaxNArr, & - Arr, NArr, U - -! !USES: - IMPLICIT NONE -! == Global variables == -#include "SIZE.h" -#include "GRID.h" -#include "EEPARAMS.h" -#include "EESUPPORT.h" -#include "PARAMS.h" -#include "IHOP_SIZE.h" -#include "IHOP.h" -#ifdef ALLOW_CTRL -# include "CTRL_FIELDS.h" -#endif +MODULE init_mod +PRIVATE -! == External Functions == - INTEGER ILNBLNK - EXTERNAL ILNBLNK +public ihop_init_fixed_env +CONTAINS SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) - ! !INPUT/OUTPUT PARAMETERS: + ! Initiate fixed variable for ihop time series. Note: NO IHOP_THREED here + ! =========================================================================== + + ! USES + IMPLICIT NONE + USE bdry_mod, only: Bdry, HSInfo + USE srpos_mod, only: Pos, ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec + USE ssp_mod, only: SSP + USE ihop_mod, only: Beam, rxyz + USE angle_mod, only: Angles, ReadRayElevationAngles + + ! =========================================================================== + ! == Global Variables == +#include "IHOP_SIZE.h" +#include "IHOP.h" + + ! =========================================================================== ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + + ! =========================================================================== ! == Local Variables == - INTEGER :: iostat, iAllocStat, ierr + INTEGER :: iAllocStat, ierr INTEGER :: jj - REAL :: Tstart, Tstop ! added locally previously read in from unknown mod ... IEsco22 CHARACTER ( LEN=2 ) :: AttenUnit - ! =========================================================================== INTEGER :: iSeg INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 + ! =========================================================================== + !IESCO24: some notes while I noodle ! Use data.ihop, set time series invariant parameters. These are fixed ! parameters that do not depend on which time step you run ihop in. ! Primarily, the parameters are related to the acoustic grid: @@ -79,172 +58,358 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) ! This subroutine will set parameters that shouldn't need to be modified ! throughout the MITgcm model run - ! save data.ihop, gcm SSP: REQUIRED - CALL initEnv( myTime, myIter, myThid ) - ! AlTImetry: OPTIONAL, default is no ATIFile - CALL initATI( Bdry%Top%HS%Opt( 5:5 ), Bdry%Top%HS%Depth, myThid ) - ! BaThYmetry: OPTIONAL, default is BTYFile - CALL initBTY( Bdry%Bot%HS%Opt( 2:2 ), Bdry%Bot%HS%Depth, myThid ) - ! (top and bottom): OPTIONAL - CALL readReflectionCoefficient( Bdry%Bot%HS%Opt( 1:1 ), & - Bdry%Top%HS%Opt( 2:2 ), myThid ) - ! Source Beam Pattern: OPTIONAL, default is omni source pattern - SBPFlag = Beam%RunType( 3:3 ) - CALL readPat( myThid ) - Pos%Ntheta = 1 - ALLOCATE( Pos%theta( Pos%Ntheta ), Stat = IAllocStat ) - IF ( IAllocStat/=0 ) THEN -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: failed allocation Pos%theta' - CALL PRINT_ERROR( msgBuf, myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R IHOP_INIT' - ENDIF - Pos%theta( 1 ) = 0. - + ! === Set nonallocatable derived type components from other modules === + Bdry%Bot%HS = HSInfo(0.,0.,0.,0., 0.,0. , (0.,0.),(0.,0.), '', '' ) + Bdry%Top%HS = HSInfo(0.,0.,0.,0., 0.,0. , (0.,0.),(0.,0.), '', '' ) -! Allocate arrival and U variables on all MPI processes - SELECT CASE ( Beam%RunType( 5:5 ) ) - CASE ( 'I' ) - NRz_per_range = 1 ! irregular grid - CASE DEFAULT - NRz_per_range = Pos%NRz ! rectilinear grid - END SELECT - - IF ( ALLOCATED( U ) ) DEALLOCATE( U ) - SELECT CASE ( Beam%RunType( 1:1 ) ) - ! for a TL calculation, allocate space for the pressure matrix - CASE ( 'C', 'S', 'I' ) ! TL calculation - ALLOCATE ( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) - IF ( iAllocStat/=0 ) THEN -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & - 'Insufficient memory for TL matrix: reduce Nr*NRz' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R IHOP_INIT' - END IF - U = 0.0 ! init default value - CASE ( 'A', 'a', 'R', 'E', 'e' ) ! Arrivals calculation - ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable - U( 1,1 ) = 0. ! init default value - CASE DEFAULT - ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable - U( 1,1 ) = 0. ! init default value - END SELECT - - ! for an arrivals run, allocate space for arrivals matrices - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'A', 'a', 'e' ) - ! allow space for at least MinNArr arrivals - MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & - MinNArr ) - ALLOCATE ( Arr( MaxNArr, Pos%NRr, NRz_per_range ), & - NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) - IF ( iAllocStat /= 0 ) THEN -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & - 'Not enough allocation for Arr; reduce ArrivalsStorage' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R IHOP_INIT' - END IF - CASE DEFAULT - MaxNArr = 1 - ALLOCATE ( Arr( 1, NRz_per_range, Pos%NRr ), & - NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) - END SELECT - - ! init Arr, Narr - ! Arr = something - NArr( 1:Pos%NRr, 1:NRz_per_range ) = 0 ! IEsco22 unnecessary? NArr = 0 below - + Pos%NSx = -1 + Pos%NSy = -1 + Pos%NSz = -1 + Pos%NRz = -1 + Pos%NRr = -1 + Pos%Ntheta = -1 + Pos%Delta_r = -999. + Pos%Delta_theta = -999. + + SSP%NPts = -1. + SSP%Nr = -1. + SSP%Nx = -1. + SSP%Ny = -1. + SSP%Nz = -1. + SSP%z = -1. + SSP%rho = -1. + SSP%c = -1. + SSP%n2 = -1. + SSP%n2z = -1. + SSP%cSpline = -1. + SSP%cCoef = (-1.,-1.) + SSP%cSWork = (-1.,-1.) + SSP%Type = '' + SSP%AttenUnit = '' + + Beam%NBeams = -1 + Beam%NImage = -1 + Beam%NSteps = -1 + Beam%iBeamWindow = -1 + Beam%deltas = -1. + Beam%epsMultiplier = 1. + Beam%rLoop = -1. + Beam%Component = '' + Beam%Type = 'G S ' + Beam%RunType = '' + Beam%Box = rxyz(0.,0.,0.,0.) + + Angles%Nalpha = 0 + Angles%iSingle_alpha = 0 + Angles%Dalpha = -1. + + ! === From initenvihop.f90:initEnv === + ! *** Top Boundary *** + Bdry%Top%HS%Opt = IHOP_topopt + Bdry%Top%HS%Depth = 0 !initiate to dummy value + + CALL ReadTopOpt( Bdry%Top%HS%BC, AttenUnit, myThid ) + CALL TopBot( AttenUnit, Bdry%Top%HS, myThid ) + + + ! *** Bottom Boundary *** + Bdry%Bot%HS%Opt = IHOP_botopt + IF ( IHOP_depth.NE.0 ) THEN + Bdry%Bot%HS%Depth = IHOP_depth + ELSE + ! Extend by 5 wavelengths + Bdry%Bot%HS%Depth = rkSign*rF( Nr+1 ) + 5*c0/IHOP_freq + END IF + + Bdry%Bot%HS%BC = Bdry%Bot%HS%Opt( 1:1 ) + CALL TopBot( AttenUnit, Bdry%Bot%HS, myThid ) + + SELECT CASE ( Bdry%Bot%HS%Opt( 2:2 ) ) + CASE( '~', '*' ) + CASE( ' ' ) + CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + WRITE(msgBuf,'(A)') 'INITENVIHOP initEnv: Unknown Bdry%Bot%HS%Opt(2)' + CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R initEnv' + END SELECT + ! *** SSP parameters *** + x = [ 0.0 _d 0, Bdry%Bot%HS%Depth ] + CALL initSSP( x, myThid ) -! open all output files - IF ( IHOP_dumpfreq .GE. 0 ) & - CALL OpenOutputFiles( IHOP_fileroot, myTime, myIter, myThid ) - - ! Run Bellhop solver on a single processor - if (numberOfProcs.gt.1) then -! Use same single processID as IHOP COST package -! if(myProcId.eq.(numberOfProcs-1)) then - if(myProcId.eq.0) then - CALL CPU_TIME( Tstart ) - CALL BellhopCore(myThid) - CALL CPU_TIME( Tstop ) -! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. -!#ifdef ALLOW_COST -! ! Broadcast info to all MPI procs for COST function accumulation -! print *, "escobar: broacasting from pid ", myProcId -! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) -! -!#endif /* ALLOW_COST */ - endif - else - CALL CPU_TIME( Tstart ) - CALL BellhopCore(myThid) - CALL CPU_TIME( Tstop ) - endif - + ! set Bdry%Top%HS%Depth from first SSP%z + Bdry%Top%HS%Depth = SSP%z(1) + ! set water column depth + Depth = Bdry%Bot%HS%Depth - Bdry%Top%HS%Depth + + + ! *** Source locations *** + CALL ReadSxSy( myThid ) ! Read source/receiver x-y coordinates + + Pos%NSz = IHOP_nsd + Pos%NRz = IHOP_nrd + + CALL AllocatePos( Pos%NSz, Pos%Sz, IHOP_sd ) + CALL AllocatePos( Pos%NRz, Pos%Rz, IHOP_rd ) + CALL ReadSzRz( Bdry%Top%HS%Depth, Bdry%Bot%HS%Depth, myThid ) + + + ! *** Receiver locations *** + Pos%NRr = IHOP_nrr + CALL AllocatePos( Pos%NRr, Pos%Rr, IHOP_rr ) + CALL ReadRcvrRanges( myThid ) + + + ! *** Broadband frequencies *** + CALL ReadfreqVec( Bdry%Top%HS%Opt( 6:6 ), myThid ) + + + ! *** Run type *** + Beam%RunType = IHOP_runopt + CALL ReadRunType( Beam%RunType, PlotType, myThid ) + CALL ReadRayElevationAngles( Depth, Bdry%Top%HS%Opt, Beam%RunType, myThid ) + + + ! *** Acoustic grid *** + ! Step size in meters [m] + Beam%deltas = IHOP_step + + ! Automatic step size option + IF ( Beam%deltas == 0.0 ) THEN + Beam%deltas = ( Depth ) / 10. + END IF + + ! Domain size + Beam%Box%Z = Bdry%Bot%HS%Depth ! in [m] + ! Extend beam box by a single step size forward + Beam%Box%R = IHOP_rr(nrd)*1000. + Beam%deltas ! in [m] + + + ! *** Beam characteristics *** + Beam%Type( 4:4 ) = Beam%RunType( 7:7 ) ! selects beam shift option + + ! don't worry about the beam type if this is a ray trace run + ! IESCO23: using 'e' requires Beam%Type to be set + IF ( Beam%RunType( 1:1 ) /= 'R' .OR. Beam%RunType( 1:1 ) /= 'E' ) THEN + + ! Beam%Type( 1 : 1 ) is + ! 'G' or '^' Geometric hat beams in Cartesian coordinates + ! 'g' Geometric hat beams in ray-centered coordinates + ! 'B' Geometric Gaussian beams in Cartesian coordinates + ! 'b' Geometric Gaussian beams in ray-centered coordinates + ! 'S' Simple Gaussian beams + ! Beam%Type( 2 : 2 ) controls the setting of the beam width + ! 'F' space Filling + ! 'M' minimum width + ! 'W' WKB beams + ! Beam%Type( 3 : 3 ) controls curvature changes on boundary reflections + ! 'D' Double + ! 'S' Single + ! 'Z' Zero + ! Beam%Type( 4 : 4 ) selects whether beam shifts are implemented on + ! boundary reflection + ! 'S' yes + ! 'N' no + + ! Curvature change can cause overflow in grazing case + ! Suppress by setting BeamType( 3 : 3 ) = 'Z' + + Beam%Type( 1:1 ) = Beam%RunType( 2:2 ) + + SELECT CASE ( Beam%Type( 1:1 ) ) + CASE ( 'G', 'g' , '^', 'B', 'b', 'S' ) + CASE DEFAULT #ifdef IHOP_WRITE_OUT - IF ( IHOP_dumpfreq.GE.0 ) THEN - ! print run time - if (numberOfProcs.gt.1) then - if(myProcId.ne.(numberOfProcs-1)) then - WRITE(msgBuf,'(A,I4,A)') 'NOTE: Proc ',myProcId, & - " didn't run ihop" - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - endif - endif - WRITE(msgBuf, '(A)' ) - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - WRITE(msgBuf, '(A,G15.3,A)' ) 'CPU Time = ', Tstop-Tstart, 's' - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - - ! close all files - IF ( IHOP_dumpfreq .GE. 0) THEN - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'C', 'S', 'I' ) ! TL calculation - CLOSE( SHDFile ) - CASE ( 'A', 'a' ) ! arrivals calculation - CLOSE( ARRFile ) - CASE ( 'R', 'E' ) ! ray and eigen ray trace - CLOSE( RAYFile ) - CASE ( 'e' ) - CLOSE( RAYFile ) - CLOSE( ARRFile ) - IF ( writeDelay ) CLOSE( DELFile ) - END SELECT - - if (numberOfProcs.gt.1) then - ! Erase prtfiles that aren't on procid = 0 - if(myProcId.ne.0) then - CLOSE(PRTFile, STATUS='DELETE') - else - CLOSE(PRTFile) - endif - else - CLOSE(PRTFile) - endif - ENDIF - ENDIF + ! Only do I/O if in the main thread + _BEGIN_MASTER(myThid) + WRITE(msgBuf,'(2A)') 'INITENVIHOP initEnv: ', & + 'Unknown beam type (second letter of Beam%Type)' + CALL PRINT_ERROR( msgBuf,myThid ) + ! Only do I/O in the main thread + _END_MASTER(myThid) #endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R initEnv' + END SELECT + + END IF ! Beam%RunType( 1:1 ) /= 'R' ... + + +! ================= +! ================= Below from BELLHOP.F90:IHOP_INIT +! ================= +! +! +! +! +! ! save data.ihop, gcm SSP: REQUIRED +! CALL initEnv( myTime, myIter, myThid ) +! ! AlTImetry: OPTIONAL, default is no ATIFile +! CALL initATI( Bdry%Top%HS%Opt( 5:5 ), Bdry%Top%HS%Depth, myThid ) +! ! BaThYmetry: OPTIONAL, default is BTYFile +! CALL initBTY( Bdry%Bot%HS%Opt( 2:2 ), Bdry%Bot%HS%Depth, myThid ) +! ! (top and bottom): OPTIONAL +! CALL readReflectionCoefficient( Bdry%Bot%HS%Opt( 1:1 ), & +! Bdry%Top%HS%Opt( 2:2 ), myThid ) +! ! Source Beam Pattern: OPTIONAL, default is omni source pattern +! SBPFlag = Beam%RunType( 3:3 ) +! CALL readPat( myThid ) +! Pos%Ntheta = 1 +! ALLOCATE( Pos%theta( Pos%Ntheta ), Stat = IAllocStat ) +! IF ( IAllocStat/=0 ) THEN +!#ifdef IHOP_WRITE_OUT +! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: failed allocation Pos%theta' +! CALL PRINT_ERROR( msgBuf, myThid ) +!#endif /* IHOP_WRITE_OUT */ +! STOP 'ABNORMAL END: S/R IHOP_INIT' +! ENDIF +! Pos%theta( 1 ) = 0. +! +! +!! Allocate arrival and U variables on all MPI processes +! SELECT CASE ( Beam%RunType( 5:5 ) ) +! CASE ( 'I' ) +! NRz_per_range = 1 ! irregular grid +! CASE DEFAULT +! NRz_per_range = Pos%NRz ! rectilinear grid +! END SELECT +! +! IF ( ALLOCATED( U ) ) DEALLOCATE( U ) +! SELECT CASE ( Beam%RunType( 1:1 ) ) +! ! for a TL calculation, allocate space for the pressure matrix +! CASE ( 'C', 'S', 'I' ) ! TL calculation +! ALLOCATE ( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) +! IF ( iAllocStat/=0 ) THEN +!#ifdef IHOP_WRITE_OUT +! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & +! 'Insufficient memory for TL matrix: reduce Nr*NRz' +! CALL PRINT_ERROR( msgBuf,myThid ) +!#endif /* IHOP_WRITE_OUT */ +! STOP 'ABNORMAL END: S/R IHOP_INIT' +! END IF +! U = 0.0 ! init default value +! CASE ( 'A', 'a', 'R', 'E', 'e' ) ! Arrivals calculation +! ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable +! U( 1,1 ) = 0. ! init default value +! CASE DEFAULT +! ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable +! U( 1,1 ) = 0. ! init default value +! END SELECT +! +! ! for an arrivals run, allocate space for arrivals matrices +! SELECT CASE ( Beam%RunType( 1:1 ) ) +! CASE ( 'A', 'a', 'e' ) +! ! allow space for at least MinNArr arrivals +! MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & +! MinNArr ) +! ALLOCATE ( Arr( MaxNArr, Pos%NRr, NRz_per_range ), & +! NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) +! IF ( iAllocStat /= 0 ) THEN +!#ifdef IHOP_WRITE_OUT +! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & +! 'Not enough allocation for Arr; reduce ArrivalsStorage' +! CALL PRINT_ERROR( msgBuf,myThid ) +!#endif /* IHOP_WRITE_OUT */ +! STOP 'ABNORMAL END: S/R IHOP_INIT' +! END IF +! CASE DEFAULT +! MaxNArr = 1 +! ALLOCATE ( Arr( 1, NRz_per_range, Pos%NRr ), & +! NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) +! END SELECT +! +! ! init Arr, Narr +! ! Arr = something +! NArr( 1:Pos%NRr, 1:NRz_per_range ) = 0 ! IEsco22 unnecessary? NArr = 0 below +! +!#ifdef IHOP_WRITE_OUT +! WRITE(msgBuf,'(A)') +! ! In adjoint mode we do not write output besides on the first run +! IF (IHOP_dumpfreq.GE.0) & +! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) +!#endif /* IHOP_WRITE_OUT */ +! +! +! +!! open all output files +! IF ( IHOP_dumpfreq .GE. 0 ) & +! CALL OpenOutputFiles( IHOP_fileroot, myTime, myIter, myThid ) +! +! ! Run Bellhop solver on a single processor +! if (numberOfProcs.gt.1) then +!! Use same single processID as IHOP COST package +!! if(myProcId.eq.(numberOfProcs-1)) then +! if(myProcId.eq.0) then +! CALL CPU_TIME( Tstart ) +! CALL BellhopCore(myThid) +! CALL CPU_TIME( Tstop ) +!! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. +!!#ifdef ALLOW_COST +!! ! Broadcast info to all MPI procs for COST function accumulation +!! print *, "escobar: broacasting from pid ", myProcId +!! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) +!! +!!#endif /* ALLOW_COST */ +! endif +! else +! CALL CPU_TIME( Tstart ) +! CALL BellhopCore(myThid) +! CALL CPU_TIME( Tstop ) +! endif +! +!#ifdef IHOP_WRITE_OUT +! IF ( IHOP_dumpfreq.GE.0 ) THEN +! ! print run time +! if (numberOfProcs.gt.1) then +! if(myProcId.ne.(numberOfProcs-1)) then +! WRITE(msgBuf,'(A,I4,A)') 'NOTE: Proc ',myProcId, & +! " didn't run ihop" +! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) +! endif +! endif +! WRITE(msgBuf, '(A)' ) +! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) +! WRITE(msgBuf, '(A,G15.3,A)' ) 'CPU Time = ', Tstop-Tstart, 's' +! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) +! +! ! close all files +! IF ( IHOP_dumpfreq .GE. 0) THEN +! SELECT CASE ( Beam%RunType( 1:1 ) ) +! CASE ( 'C', 'S', 'I' ) ! TL calculation +! CLOSE( SHDFile ) +! CASE ( 'A', 'a' ) ! arrivals calculation +! CLOSE( ARRFile ) +! CASE ( 'R', 'E' ) ! ray and eigen ray trace +! CLOSE( RAYFile ) +! CASE ( 'e' ) +! CLOSE( RAYFile ) +! CLOSE( ARRFile ) +! IF ( writeDelay ) CLOSE( DELFile ) +! END SELECT +! +! if (numberOfProcs.gt.1) then +! ! Erase prtfiles that aren't on procid = 0 +! if(myProcId.ne.0) then +! CLOSE(PRTFile, STATUS='DELETE') +! else +! CLOSE(PRTFile) +! endif +! else +! CLOSE(PRTFile) +! endif +! ENDIF +! ENDIF +!#endif /* IHOP_WRITE_OUT */ RETURN END !SUBROUTINE IHOP_INIT ! **********************************************************************! - SUBROUTINE BellhopCore( myThid ) - USE ssp_mod, only: iSegr !RG -! USE influence, only: ratio1, rB !RG + SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) + USE atten_mod, only: T, Salinity, pH, z_bar, iBio, NBioLayers, bio + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. @@ -252,180 +417,85 @@ SUBROUTINE BellhopCore( myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - INTEGER :: IBPvec( 1 ), ibp, is, iBeamWindow2, Irz1, Irec, & - NalphaOpt - REAL (KIND=_RL90) :: Amp0, DalphaOpt, xs( 2 ), RadMax, s, & - c, cimag, gradc( 2 ), crr, crz, czz, rho + CHARACTER (LEN= 1), INTENT( OUT ) :: BC ! Boundary condition type + CHARACTER (LEN= 2), INTENT( INOUT ) :: AttenUnit -!$TAF init BellhopCore1 = static, Pos%NSz -!$TAF init BellhopCore2 = static, Pos%NSz*Angles%Nalpha + SSP%Type = IHOP_TopOpt( 1:1 ) + BC = IHOP_TopOpt( 2:2 ) + AttenUnit = IHOP_TopOpt( 3:4 ) + SSP%AttenUnit = AttenUnit - afreq = 2.0 * PI * IHOP_freq - - Angles%alpha = Angles%alpha * deg2rad ! convert to radians - Angles%Dalpha = 0.0 - IF ( Angles%Nalpha > 1 ) THEN - Angles%Dalpha = ( Angles%alpha( Angles%Nalpha ) - Angles%alpha( 1 ) ) & - / ( Angles%Nalpha - 1 ) ! angular spacing between beams - ELSE + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.LT.0) RETURN + + ! SSP approximation options + SELECT CASE ( SSP%Type ) + CASE ( 'N','C','P','S','Q','A' ) + CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP BellhopCore: ', & - 'Required: Nalpha>1, else add iSingle_alpha(see angleMod)' + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + 'Unknown option for SSP approximation' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R BellhopCore' - END IF - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! begin solve ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - SourceDepth: DO is = 1, Pos%NSz - -!$TAF store beam = BellhopCore1 -! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod -! Scalar components -! Fixed arrays -!$TAF store ssp%z = BellhopCore1 -! Allocatable arrays -!$TAF store ssp%cmat,ssp%czmat = BellhopCore1 - - xs = [ zeroRL, Pos%Sz( is ) ] ! source coordinate, assuming source @ r=0 - - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'C','S','I' ) ! TL calculation, zero out pressure matrix - U = 0.0 - CASE ( 'A','a','e' ) ! Arrivals calculation, zero out arrival matrix - NArr = 0 - END SELECT - - CALL evalSSP( xs, c, cimag, gradc, crr, crz, czz, rho, myThid ) - - !!IESCO22: BEAM stuff !! - RadMax = 5 * c / IHOP_freq ! 5 wavelength max radius IEsco22: unused - IF ( Beam%RunType( 1:1 ) == 'C' ) THEN ! for Coherent TL Run - ! Are there enough rays? - DalphaOpt = SQRT( c / ( 6.0 * IHOP_freq * Pos%Rr( Pos%NRr ) ) ) - NalphaOpt = 2 + INT( ( Angles%alpha( Angles%Nalpha ) & - - Angles%alpha( 1 ) ) / DalphaOpt ) + STOP 'ABNORMAL END: S/R ReadTopOpt' + END SELECT + + ! Attenuation options + SELECT CASE ( AttenUnit( 1:1 ) ) + CASE ( 'N','F','M','W','Q','L' ) + CASE DEFAULT #ifdef IHOP_WRITE_OUT - IF ( Angles%Nalpha < NalphaOpt ) THEN - WRITE( msgBuf, '(A,/,A,I10.4)' ) 'WARNING: Too few beams',& - 'Nalpha should be at least = ', NalphaOpt - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - ENDIF + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + 'Unknown attenuation units' + CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - ENDIF - !!IESCO22: end BEAM stuff !! - - ! Trace successive beams - DeclinationAngle: DO ialpha = 1, Angles%Nalpha -!$TAF store arr,bdry,isegr,narr,u = BellhopCore2 -!!$TAF store ratio1,rb = BellhopCore2 -! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod -! Scalar components -! Fixed arrays -! Allocatable arrays -!$TAF store ssp%cmat,ssp%czmat = BellhopCore2 - ! take-off declination angle in degrees - SrcDeclAngle = rad2deg * Angles%alpha( ialpha ) - - ! Single ray run? then don't visit code below - IF ( Angles%iSingle_alpha==0 .OR. ialpha==Angles%iSingle_alpha ) THEN - - !!IESCO22: BEAM stuff !! - IBPvec = maxloc( SrcBmPat( :, 1 ), mask = SrcBmPat( :, 1 ) & - < SrcDeclAngle ) ! index of ray angle in beam pattern - IBP = IBPvec( 1 ) - IBP = MAX( IBP, 1 ) ! don't go before beginning of table - IBP = MIN( IBP, NSBPPts - 1 ) ! don't go past end of table - ! IEsco22: When a beam pattern isn't specified, IBP = 1 - - ! linear interpolation to get amplitude - s = ( SrcDeclAngle - SrcBmPat( IBP, 1 ) ) & - / ( SrcBmPat( IBP + 1, 1 ) - SrcBmPat( IBP, 1 ) ) - Amp0 = ( 1 - s ) * SrcBmPat( IBP, 2 ) + s * SrcBmPat( IBP + 1, 2 ) - ! IEsco22: When a beam pattern isn't specified, Amp0 = 0 - - ! Lloyd mirror pattern for semi-coherent option - IF ( Beam%RunType( 1:1 ) == 'S' ) & - Amp0 = Amp0 * SQRT( 2.0 ) * ABS( SIN( afreq / c * xs( 2 ) & - * SIN( Angles%alpha( ialpha ) ) ) ) - !!IESCO22: end BEAM stuff !! - + STOP 'ABNORMAL END: S/R ReadTopOpt' + END SELECT + + ! optional addition of volume attenuation using standard formulas + SELECT CASE ( AttenUnit( 2:2 ) ) + CASE ( 'T','F','B',' ' ) + CASE DEFAULT #ifdef IHOP_WRITE_OUT - ! report progress in PRTFile (skipping some angles) - IF ( MOD( ialpha - 1, max( Angles%Nalpha / 50, 1 ) ) == 0 ) THEN - WRITE(msgBuf,'(A,I7,F10.2)') 'Tracing ray ', & - ialpha, SrcDeclAngle - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - FLUSH( PRTFile ) - END IF + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + 'Unknown top option letter in fourth position' + CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - - ! Trace a ray, update ray2D structure - CALL TraceRay2D( xs, Angles%alpha( ialpha ), Amp0, myThid ) - - ! Write the ray trajectory to RAYFile - IF ( Beam%RunType(1:1) == 'R') THEN - CALL WriteRay2D( SrcDeclAngle, Beam%Nsteps ) - IF (writeDelay) CALL WriteDel2D( SrcDeclAngle, Beam%Nsteps ) - ELSE ! Compute the contribution to the field - SELECT CASE ( Beam%Type( 1:1 ) ) - CASE ( 'g' ) - CALL InfluenceGeoHatRayCen( U, Angles%alpha( ialpha ), & - Angles%Dalpha, myThid ) - CASE ( 'B' ) - CALL InfluenceGeoGaussianCart( U, Angles%alpha( ialpha ), & - Angles%Dalpha, myThid ) - CASE ( 'G','^' ) - CALL InfluenceGeoHatCart( U, Angles%alpha( ialpha ), & - Angles%Dalpha, myThid ) - CASE DEFAULT !IEsco22: thesis is in default behavior - CALL InfluenceGeoHatCart( U, Angles%alpha( ialpha ), & - Angles%Dalpha, myThid ) - END SELECT - END IF - - END IF - END DO DeclinationAngle - - ! write results to disk - - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'C', 'S', 'I' ) ! TL calculation - CALL ScalePressure( Angles%Dalpha, ray2D( 1 )%c, Pos%Rr, U, & - NRz_per_range, Pos%NRr, Beam%RunType, IHOP_freq ) - IRec = 10 + NRz_per_range * ( is - 1 ) - RcvrDepth: DO Irz1 = 1, NRz_per_range - IRec = IRec + 1 - WRITE( SHDFile, REC = IRec ) U( Irz1, 1:Pos%NRr ) - END DO RcvrDepth - CASE ( 'A', 'e' ) ! arrivals calculation, ascii - CALL WriteArrivalsASCII( Pos%Rr, NRz_per_range, Pos%NRr, & - Beam%RunType( 4:4 ) ) - CASE ( 'a' ) ! arrivals calculation, binary - CALL WriteArrivalsBinary( Pos%Rr, NRz_per_range, Pos%NRr, & - Beam%RunType( 4:4 ) ) - END SELECT - - END DO SourceDepth - + STOP 'ABNORMAL END: S/R ReadTopOpt' + END SELECT + + SELECT CASE ( IHOP_TopOpt( 5:5 ) ) + CASE ( '~', '*' ) + CASE ( '-', '_', ' ' ) + CASE DEFAULT +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + 'Unknown top option letter in fifth position' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R ReadTopOpt' + END SELECT + + SELECT CASE ( IHOP_TopOpt( 6:6 ) ) + CASE ( 'I' ) + CASE ( ' ' ) + CASE DEFAULT +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + 'Unknown top option letter in sixth position' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R ReadTopOpt' + END SELECT + RETURN - END !SUBROUTINE BellhopCore - - ! **********************************************************************! - - SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) - - ! Traces the beam corresponding to a particular take-off angle, alpha [rad] - - USE ihop_mod, only: MaxN, istep - USE step, only: Step2D - USE ssp_mod, only: iSegr !RG + END !SUBROUTINE ReadTopOpt + + !**********************************************************************! + SUBROUTINE TopBot( AttenUnit, HS, myThid ) + ! Handles top and bottom boundary conditions + use atten_mod, only: CRCI + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. @@ -433,268 +503,89 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - REAL (KIND=_RL90), INTENT( IN ) :: xs(2) ! coordinate of source - REAL (KIND=_RL90), INTENT( IN ) :: alpha, Amp0 ! angle in rad, beam amp - INTEGER :: is, is1 ! indices for ray step - REAL (KIND=_RL90) :: c, cimag, gradc(2), crr, crz, czz, rho - REAL (KIND=_RL90) :: dEndTop(2), dEndBot(2), TopnInt(2), BotnInt(2), & - ToptInt(2), BottInt(2), rayt(2), raytOld(2) - ! Distances from ray beginning, end to top and bottom - REAL (KIND=_RL90) :: DistBegTop, DistEndTop, DistBegBot, DistEndBot - REAL (KIND=_RL90) :: sss, declAlpha, declAlphaOld - LOGICAL :: RayTurn = .FALSE., continue_steps - -!$TAF init TraceRay2D = static, MaxN-1 - - ! Initial conditions (IC) - iSmallStepCtr = 0 - CALL evalSSP( xs, c, cimag, gradc, crr, crz, czz, rho, myThid ) - ray2D( 1 )%c = c ! sound speed at source [m/s] - ray2D( 1 )%x = xs ! range and depth of source - ray2D( 1 )%t = [ COS( alpha ), SIN( alpha ) ] / c ! unit tangent / c - ray2D( 1 )%p = [ 1.0, 0.0 ] ! IESCO22: slowness vector - ! second component of qv is not supported in geometric beam tracing - ! set I.C. to 0 in hopes of saving run time - IF ( Beam%RunType( 2:2 ) == 'G' .or. Beam%RunType( 2:2 ) == 'B') THEN - ray2D( 1 )%q = [ 0.0, 0.0 ] ! IESCO22: geometric beam in Cartesian - ELSE - ray2D( 1 )%q = [ 0.0, 1.0 ] ! IESCO22: ray centered coords - END IF - ray2D( 1 )%tau = 0.0 - ray2D( 1 )%Amp = Amp0 - ray2D( 1 )%Phase = 0.0 - ray2D( 1 )%NumTopBnc = 0 - ray2D( 1 )%NumBotBnc = 0 - ray2D( 1 )%NumTurnPt = 0 - - ! IESCO22: update IsegTop, rTopSeg and IsegBot, rBotSeg in bdrymod.f90 - CALL GetTopSeg( xs(1), myThid ) ! find alimetry segment above the source - CALL GetBotSeg( xs(1), myThid ) ! find bathymetry segment below the source - - ! IESCO22: 'L' is long format. See BeadBTY s/r in bdrymod.f90. Default is to - ! calculate cp, cs, and rho instead of reading them in - IF ( atiType( 2 : 2 ) == 'L' ) THEN - ! grab the geoacoustic info for the new segment - Bdry%Top%HS%cp = Top( IsegTop )%HS%cp - Bdry%Top%HS%cs = Top( IsegTop )%HS%cs - Bdry%Top%HS%rho = Top( IsegTop )%HS%rho - END IF - IF ( btyType( 2 : 2 ) == 'L' ) THEN - Bdry%Bot%HS%cp = Bot( IsegBot )%HS%cp - Bdry%Bot%HS%cs = Bot( IsegBot )%HS%cs - Bdry%Bot%HS%rho = Bot( IsegBot )%HS%rho - END IF - - CALL Distances2D( ray2D( 1 )%x, Top( IsegTop )%x, Bot( IsegBot )%x, & - dEndTop, dEndBot, & - Top( IsegTop )%n, Bot( IsegBot )%n, & - DistBegTop, DistBegBot ) - - IF ( DistBegTop <= 0 .OR. DistBegBot <= 0 ) THEN - Beam%Nsteps = 1 -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') & - 'WARNING: TraceRay2D: The source is outside the domain boundaries' - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) -#endif /* IHOP_WRITE_OUT */ - RETURN ! source must be within the domain - END IF - + CHARACTER (LEN=2), INTENT( IN ) :: AttenUnit + TYPE ( HSInfo ), INTENT( INOUT ) :: HS + REAL (KIND=_RL90) :: Mz, vr, alpha2_f ! values related to grain size + REAL (KIND=_RL90) :: ztemp, bPower, fT + ! FROM SSP_MOD.F90 + REAL (KIND=_RL90) :: alphaR = 1500., betaR = 0., alphaI = 0., & + betaI = 0., rhoR = 1. - ! Trace the beam (Reflect2D increments the step index, is) - is = 0 - continue_steps = .true. - Stepping: DO istep = 1, MaxN - 1 -!$TAF store bdry,beam,continue_steps,distbegbot,distbegtop = TraceRay2D -!$TAF store isegbot,isegtop,ray2d,rbotseg,rtopseg = TraceRay2D -! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod -! Scalar components -! Fixed arrays -! Allocatable arrays -!$TAF store ssp%cmat,ssp%czmat = TraceRay2D - IF ( continue_steps ) THEN -!$TAF store is = TraceRay2D - is = is + 1 ! old step - is1 = is + 1 ! new step forward - - CALL Step2D( ray2D( is ), ray2D( is1 ), & - Top( IsegTop )%x, Top( IsegTop )%n, & - Bot( IsegBot )%x, Bot( IsegBot )%n, myThid ) - - ! IESCO22: turning point check - IF ( is > 1 ) THEN - rayt = ray2D(is1)%x - ray2D(is)%x - raytOld = ray2D(is)%x - ray2D(is-1)%x - declAlpha = ATAN2( rayt(2), rayt(1) ) - declAlphaOld = ATAN2( raytOld(2), raytOld(1) ) - RayTurn = ( declAlpha <= 0.0d0 .AND. declAlphaOld > 0.0d0 .OR. & - declAlpha >= 0.0d0 .AND. declAlphaOld < 0.0d0 ) - IF ( RayTurn) THEN - ray2D( is1 )%NumTurnPt = ray2D( is )%NumTurnPt + 1 - END IF - END IF - - ! New altimetry segment? - IF ( ray2D( is1 )%x( 1 ) < rTopSeg( 1 ) .OR. & - ray2D( is1 )%x( 1 ) > rTopSeg( 2 ) ) THEN - CALL GetTopSeg( ray2D( is1 )%x( 1 ), myThid ) - IF ( atiType( 2 : 2 ) == 'L' ) THEN - ! ATIFile geoacoustic info from new segment, cp - Bdry%Top%HS%cp = Top( IsegTop )%HS%cp - Bdry%Top%HS%cs = Top( IsegTop )%HS%cs - Bdry%Top%HS%rho = Top( IsegTop )%HS%rho - END IF - END IF - - ! New bathymetry segment? - IF ( ray2D( is1 )%x( 1 ) < rBotSeg( 1 ) .OR. & - ray2D( is1 )%x( 1 ) > rBotSeg( 2 ) ) THEN - CALL GetBotSeg( ray2D( is1 )%x( 1 ), myThid ) - IF ( btyType( 2 : 2 ) == 'L' ) THEN - ! BTYFile geoacoustic info from new segment, cp - Bdry%Bot%HS%cp = Bot( IsegBot )%HS%cp - Bdry%Bot%HS%cs = Bot( IsegBot )%HS%cs - Bdry%Bot%HS%rho = Bot( IsegBot )%HS%rho - END IF - END IF - - ! *** Reflections *** - ! Tests ray at step is IS inside, and ray at step is+1 IS outside - ! DistBeg is the distance at step is, which is saved - ! DistEnd is the distance at step is+1, which needs to be calculated - - CALL Distances2D( ray2D( is1 )%x, & - Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & - Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) - - ! IESCO22: Did new ray point cross top boundary? Then reflect - IF ( DistBegTop > 0.0d0 .AND. DistEndTop <= 0.0d0 ) THEN - - IF ( atiType == 'C' ) THEN ! curvilinear interpolation - ! proportional distance along segment - sss = DOT_PRODUCT( dEndTop, Top( IsegTop )%t ) & - / Top( IsegTop )%Len - ToptInt = ( 1-sss ) * Top( IsegTop )%Nodet & - + sss * Top( 1+IsegTop )%Nodet - TopnInt = ( 1-sss ) * Top( IsegTop )%Noden & - + sss * Top( 1+IsegTop )%Noden - ELSE - TopnInt = Top( IsegTop )%n ! normal is constant in a segment - ToptInt = Top( IsegTop )%t - END IF - - CALL Reflect2D( is, Bdry%Top%HS, 'TOP', ToptInt, TopnInt, & - Top( IsegTop )%kappa, RTop, NTopPTS, & - myThid ) - - CALL Distances2D( ray2D( is+1 )%x, & - Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & - Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) - - ! IESCO22: Did ray cross bottom boundary? Then reflect - ELSE IF ( DistBegBot > 0.0d0 .AND. DistEndBot <= 0.0d0 ) THEN - - IF ( btyType == 'C' ) THEN ! curvilinear interpolation - ! proportional distance along segment - sss = DOT_PRODUCT( dEndBot, Bot( IsegBot )%t ) & - / Bot( IsegBot )%Len - BotnInt = ( 1-sss ) * Bot( IsegBot )%Noden & - + sss * Bot( 1+IsegBot )%Noden - BottInt = ( 1-sss ) * Bot( IsegBot )%Nodet & - + sss * Bot( 1+IsegBot )%Nodet - ELSE - BotnInt = Bot( IsegBot )%n ! normal is constant in a segment - BottInt = Bot( IsegBot )%t - END IF - - CALL Reflect2D( is, Bdry%Bot%HS, 'BOT', BottInt, BotnInt, & - Bot( IsegBot )%kappa, RBot, NBotPTS, & - myThid ) - - CALL Distances2D( ray2D( is+1 )%x, & - Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & - Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) - END IF - - ! Has the ray left the box, lost its energy, escaped the boundaries, - ! or exceeded storage limit? - ! IESCO22: Rewriting for debugging with gcov - WRITE(msgBuf,'(A)') ' ' - IF ( ray2D( is+1 )%x( 1 ) > Beam%Box%r ) THEN - WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box%r' - ELSE IF ( ray2D( is+1 )%x( 1 ) < 0 ) THEN - WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box r=0' - ELSE IF ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) THEN - WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box%z' - ELSE IF ( ABS( ray2D( is+1 )%Amp ) < 0.005 ) THEN - WRITE(msgBuf,'(A)') 'TraceRay2D: ray lost energy' - ELSE IF ( DistBegTop < 0.0 .AND. DistEndTop < 0.0 ) THEN - WRITE(msgBuf,'(A)') 'TraceRay2D: ray escaped top bound' - ELSE IF ( DistBegBot < 0.0 .AND. DistEndBot < 0.0 ) THEN - WRITE(msgBuf,'(A)') 'TraceRay2D: ray escaped bot bound' - ELSE IF ( is >= MaxN - 3 ) THEN - WRITE(msgBuf,'(2A)') 'WARNING: TraceRay2D: Check storage ',& - 'for ray trajectory' - END IF - +! ! ****** Read in BC parameters depending on particular choice ****** +! HS%cp = 0.0 +! HS%cs = 0.0 +! HS%rho = 0.0 + + ! RG recommends resetting to the default values from ssp_mod.F90 + bPower = 1.0 + fT = 1D20 + rhoR = 1.0 + + SELECT CASE ( HS%BC ) + CASE ( 'V','R','A','G','F','W','P' ) + CASE DEFAULT #ifdef IHOP_WRITE_OUT - IF ( ( ray2D( is+1 )%x( 1 ) > Beam%Box%r ) .OR. & - ( ray2D( is+1 )%x( 1 ) < 0 ) .OR. & - ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) .OR. & - ( ABS( ray2D( is+1 )%Amp ) < 0.005 ) .OR. & - ( DistBegTop < 0.0 .AND. DistEndTop < 0.0 ) .OR. & - ( DistBegBot < 0.0 .AND. DistEndBot < 0.0 ) .OR. & - ( is >= MaxN - 3 ) ) THEN - IF ( IHOP_dumpfreq .GE. 0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - ENDIF + WRITE(msgBuf,'(2A)') 'INITENVIHOP TopBot: ', & + 'Unknown boundary condition type' + CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - IF (INDEX(msgBuf, 'TraceRay2D').eq.1) THEN - Beam%Nsteps = is+1 - continue_steps = .false. - ELSE IF (INDEX(msgBuf, 'WARNING: TraceRay2D').eq.1) THEN - Beam%Nsteps = is - continue_steps = .false. - END IF - - DistBegTop = DistEndTop - DistBegBot = DistEndBot - END IF ! continue_steps - END DO Stepping - + STOP 'ABNORMAL END: S/R TopBot' + END SELECT + + SELECT CASE ( HS%BC ) + CASE ( 'A' ) ! *** Half-space properties *** + ! IEsco23: MISSING IF BOTTOM BC CHECK + zTemp = HS%Depth + alphaR = IHOP_bcsound + betaR = IHOP_bcsoundshear + rhoR = IHOP_brho + alphaI = IHOP_bcsoundI + betaI = IHOP_bcsoundshearI + + ! dummy parameters for a layer with a general power law for attenuation + ! these are not in play because the AttenUnit for this is not allowed yet + fT = 1000.0 + + HS%cp = CRCI( zTemp, alphaR, alphaI, AttenUnit, bPower, fT, myThid ) + HS%cs = CRCI( zTemp, betaR, betaI, AttenUnit, bPower, fT, myThid ) + + HS%rho = rhoR + CASE DEFAULT + END SELECT + RETURN - END !SUBROUTINE TraceRay2D - + END !SUBROUTINE TopBot + ! **********************************************************************! - - SUBROUTINE Distances2D( rayx, Topx, Botx, dTop, dBot, Topn, Botn, DistTop, & - DistBot ) - - ! Calculates the distances to the boundaries - ! Formula differs from JKPS because code applies outward pointing normals - - REAL (KIND=_RL90), INTENT( IN ) :: rayx(2) ! ray coordinate - REAL (KIND=_RL90), INTENT( IN ) :: Topx(2), Botx(2) ! top, bottom coordinate - REAL (KIND=_RL90), INTENT( IN ) :: Topn(2), Botn(2) ! top, bottom normal vector (outward) - REAL (KIND=_RL90), INTENT( OUT ) :: dTop(2), dBot(2) ! vector pointing from top, bottom bdry to ray - REAL (KIND=_RL90), INTENT( OUT ) :: DistTop, DistBot ! distance (normal to bdry) from the ray to top, bottom boundary - - dTop = rayx - Topx ! vector pointing from top to ray - dBot = rayx - Botx ! vector pointing from bottom to ray - DistTop = -DOT_PRODUCT( Topn, dTop ) - DistBot = -DOT_PRODUCT( Botn, dBot ) - + SUBROUTINE AllocatePos( Nx, x_out, x_in ) + + ! Allocate and populate Pos structure from data.ihop + + INTEGER, INTENT( IN ) :: Nx + REAL(KIND=_RL90), INTENT( IN ) :: x_in(:) + REAL(KIND=_RL90), ALLOCATABLE, INTENT( OUT ) :: x_out(:) + INTEGER :: i + + IF ( ALLOCATED(x_out) ) DEALLOCATE(x_out) + ALLOCATE( x_out(MAX(3, Nx)) ) + + ! set default values + x_out = 0.0 + x_out(3) = -999.9 + + DO i = 1, Nx + x_out(i) = x_in(i) + END DO + RETURN - END !SUBROUTINE Distances2D - - ! **********************************************************************! - - SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) - USE bdry_mod, only: HSInfo - USE refCoef, only: ReflectionCoef - + END !SUBROUTINE AllocatePos + + !**********************************************************************! + SUBROUTINE ReadRunType( RunType, PlotType, myThid ) + + ! Read the RunType variable and print to .prt file + USE srPos_mod, only: Pos + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. @@ -702,215 +593,58 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - INTEGER, INTENT( IN ) :: Npts ! unsued if there are no refcoef files - REAL (KIND=_RL90), INTENT( IN ) :: tBdry(2), nBdry(2) ! Tangent and normal to the boundary - REAL (KIND=_RL90), INTENT( IN ) :: kappa ! Boundary curvature, for curvilinear grids - CHARACTER (LEN=3), INTENT( IN ) :: BotTop ! bottom or top reflection - TYPE( HSInfo ), INTENT( IN ) :: HS ! half-space properties - TYPE(ReflectionCoef), INTENT( IN ) :: RefC( NPts ) ! reflection coefficient - INTEGER, INTENT( INOUT ) :: is - INTEGER :: is1 - REAL (KIND=_RL90) :: c, cimag, gradc( 2 ), crr, crz, czz, & - rho ! derivatives of sound speed - REAL (KIND=_RL90) :: RM, RN, Tg, Th, rayt( 2 ), rayn( 2 ), & - rayt_tilde( 2 ), rayn_tilde( 2 ), cnjump, & - csjump ! for curvature change - REAL (KIND=_RL90) :: ck, co, si, cco, ssi, pdelta, rddelta, sddelta, & - theta_bot ! for beam shift - COMPLEX (KIND=_RL90) :: kx, kz, kzP, kzS, kzP2, kzS2, mu, f, g, y2, y4, & - Refl ! for tabulated reflection coef. - COMPLEX (KIND=_RL90) :: ch, a, b, d, sb, delta, ddelta ! for beam shift - TYPE(ReflectionCoef) :: RInt - -!$TAF init reflect2d1 = 'bellhopreflectray2d' + CHARACTER (LEN= 7), INTENT( INOUT ) :: RunType + CHARACTER (LEN=10), INTENT( INOUT ) :: PlotType - ! Init default values for local derived type Rint - Rint%R = 0.0 - Rint%phi = 0.0 - Rint%theta = -999.0 + SELECT CASE ( RunType( 1:1 ) ) + CASE ( 'R','E','I','S','C','A','a','e' ) + CASE DEFAULT +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & + 'Unknown RunType selected' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R ReadRunType' + END SELECT - ! increment stepping counters - is = is + 1 ! old step - is1 = is + 1 ! new step reflected (same x, updated basis vectors) - - Tg = DOT_PRODUCT( ray2D( is )%t, tBdry ) ! ray tan projected along boundary - Th = DOT_PRODUCT( ray2D( is )%t, nBdry ) ! ray tan projected normal boundary - - ray2D( is1 )%NumTopBnc = ray2D( is )%NumTopBnc - ray2D( is1 )%NumBotBnc = ray2D( is )%NumBotBnc - ray2D( is1 )%x = ray2D( is )%x - ray2D( is1 )%t = ray2D( is )%t - 2.0 * Th * nBdry ! change ray direction - - ! Calculate change in curvature, kappa - ! Based on formulas given by Muller, Geoph. J. R.A.S., 79 (1984). - - ! Get c - CALL evalSSP( ray2D( is )%x, c, cimag, gradc, crr, crz, czz, rho, myThid ) - - ! unmodified unit ray tangent and normal - rayt = c * ray2D( is )%t ! unit tangent to ray - rayn = [ -rayt( 2 ), rayt( 1 ) ] ! unit normal to ray - - ! reflected unit ray tangent and normal - rayt_tilde = c * ray2D( is1 )%t ! unit tangent to ray - rayn_tilde = -[ -rayt_tilde( 2 ), rayt_tilde( 1 ) ] ! unit normal to ray - - ! get the jumps (this could be simplified, e.g. jump in rayt is - ! roughly 2 * Th * nbdry - cnjump = -DOT_PRODUCT( gradc, rayn_tilde - rayn ) - csjump = -DOT_PRODUCT( gradc, rayt_tilde - rayt ) - RN = 2 * kappa / c ** 2 / Th ! boundary curvature correction - - IF ( BotTop == 'TOP' ) THEN - ! cnjump changes sign because the (t,n) system of the top boundary has a - ! different sense to the bottom boundary - cnjump = -cnjump - RN = -RN - END IF - - RM = Tg / Th ! this is tan( alpha ) where alpha is the angle of incidence - RN = RN + RM * ( 2 * cnjump - RM * csjump ) / c ** 2 - - SELECT CASE ( Beam%Type( 3 : 3 ) ) - CASE ( 'D' ) - RN = 2.0 * RN - CASE ( 'Z' ) - RN = 0.0 + SELECT CASE ( RunType( 2:2 ) ) + CASE ( 'C','R','S','b','B','g' ) + CASE DEFAULT + RunType( 2:2 ) = 'G' END SELECT - - ray2D( is1 )%c = c - ray2D( is1 )%tau = ray2D( is )%tau - ray2D( is1 )%p = ray2D( is )%p + ray2D( is )%q * RN - ray2D( is1 )%q = ray2D( is )%q - - ! account for phase change - - SELECT CASE ( HS%BC ) - CASE ( 'R' ) ! rigid - ray2D( is1 )%Amp = ray2D( is )%Amp - ray2D( is1 )%Phase = ray2D( is )%Phase - CASE ( 'V' ) ! vacuum - ray2D( is1 )%Amp = ray2D( is )%Amp - ray2D( is1 )%Phase = ray2D( is )%Phase + PI - CASE ( 'F' ) ! file -!$TAF store rint = reflect2d1 - RInt%theta = rad2deg * ABS( ATAN2( Th, Tg ) ) ! angle of incidence (relative to normal to bathymetry) - IF ( RInt%theta > 90 ) RInt%theta = 180. - RInt%theta ! reflection coefficient is symmetric about 90 degrees - CALL InterpolateReflectionCoefficient( RInt, RefC, Npts ) - ray2D( is1 )%Amp = ray2D( is )%Amp * RInt%R - ray2D( is1 )%Phase = ray2D( is )%Phase + RInt%phi - CASE ( 'A', 'G' ) ! half-space - kx = afreq * Tg ! wavenumber in direction parallel to bathymetry - kz = afreq * Th ! wavenumber in direction perpendicular to bathymetry - - ! notation below is a bit mis-leading - ! kzS, kzP is really what I called gamma in other codes, and differs by a - ! factor of +/- i - IF ( REAL( HS%cS ) > 0.0 ) THEN - kzS2 = kx**2 - ( afreq / HS%cS )**2 - kzP2 = kx**2 - ( afreq / HS%cP )**2 - kzS = SQRT( kzS2 ) - kzP = SQRT( kzP2 ) - mu = HS%rho * HS%cS**2 - - y2 = ( ( kzS2 + kx**2 )**2 - 4.0D0 * kzS * kzP * kx**2 ) * mu - y4 = kzP * ( kx**2 - kzS2 ) - - f = afreq**2 * y4 - g = y2 - ELSE - kzP = SQRT( kx**2 - ( afreq / HS%cP )**2 ) - - ! Intel and GFortran compilers return different branches of the SQRT - ! for negative reals - IF ( REAL( kzP ) == 0.0D0 .AND. AIMAG( kzP ) < 0.0D0 ) kzP = -kzP - f = kzP - g = HS%rho - ENDIF - - ! complex reflection coef. - Refl = - ( rho*f - i * kz*g ) / ( rho*f + i*kz*g ) - - IF ( ABS( Refl ) < 1.0E-5 ) THEN ! kill a ray that has lost its energy in reflection - ray2D( is1 )%Amp = 0.0 - ray2D( is1 )%Phase = ray2D( is )%Phase - ELSE - ray2D( is1 )%Amp = ABS( Refl ) * ray2D( is )%Amp - ray2D( is1 )%Phase = ray2D( is )%Phase + & - ATAN2( AIMAG( Refl ), REAL( Refl ) ) - - if ( Beam%Type( 4:4 ) == 'S' ) then ! beam displacement & width change (Seongil's version) - ch = ray2D( is )%c / conjg( HS%cP ) - co = ray2D( is )%t( 1 ) * ray2D( is )%c - si = ray2D( is )%t( 2 ) * ray2D( is )%c - ck = afreq / ray2D( is )%c - - a = 2 * HS%rho * ( 1 - ch * ch ) - b = co * co - ch * ch - d = HS%rho * HS%rho * si * si + b - sb = sqrt( b ) - cco = co * co - ssi = si * si - - IF ( si /= 0.0 ) THEN - delta = a * co / si / ( ck * sb * d ) ! Do we need an abs() on this??? - ELSE - delta = 0.0 - END IF - - pdelta = real( delta ) / ( ray2D( is )%c / co) - ddelta = -a / ( ck*sb*d ) - a*cco / ssi / (ck*sb*d) & - + a*cco / (ck*b*sb*d) & - -a*co / si / (ck*sb*d*d) & - * (2* HS%rho * HS%rho *si*co-2*co*si) - rddelta = -real( ddelta ) - sddelta = rddelta / abs( rddelta ) - - ! next 3 lines have an update by Diana McCammon to allow a sloping - ! bottom . I think the formulas are good, but this won't be reliable - ! because it doesn't have the logic that tracks crossing into new - ! segments after the ray displacement. - - theta_bot = datan( tBdry( 2 ) / tBdry( 1 )) ! bottom angle - ray2D( is1 )%x( 1 ) = ray2D( is1 )%x( 1 ) + real( delta ) & - * dcos( theta_bot ) ! range displacement - ray2D( is1 )%x( 2 ) = ray2D( is1 )%x( 2 ) + real( delta ) & - * dsin( theta_bot ) ! depth displacement - ray2D( is1 )%tau = ray2D( is1 )%tau + pdelta ! phase change - ray2D( is1 )%q = ray2D( is1 )%q + sddelta * rddelta * si * c & - * ray2D( is )%p ! beam-width change - endif - - ENDIF - - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'HS%BC = ', HS%BC - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - WRITE(msgBuf,'(A)') 'BELLHOP Reflect2D: Unknown boundary condition type' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R Reflect2D' + SELECT CASE ( RunType( 4:4 ) ) + CASE ( 'R','X' ) + CASE DEFAULT + RunType( 4:4 ) = 'R' END SELECT - - ! Update top/bottom bounce counter - IF (BotTop == 'TOP') THEN - ray2D( is+1 )%NumTopBnc = ray2D( is )%NumTopBnc + 1 - ELSE IF ( BotTop == 'BOT' ) THEN - ray2D( is+1 )%NumBotBnc = ray2D( is )%NumBotBnc + 1 - ELSE + + SELECT CASE ( RunType( 5:5 ) ) + CASE ( 'R' ) + PlotType = 'rectilin ' + CASE ( 'I' ) + IF ( Pos%NRz /= Pos%NRr ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP Reflect2D: ', & - 'no reflection bounce, but in relfect2d somehow' - CALL PRINT_ERROR( msgBuf,myThid ) + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & + 'Irregular grid option selected with NRz not equal to Nr' + CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R Reflect2D' - END IF - + STOP 'ABNORMAL END: S/R ReadRunType' + END IF + PlotType = 'irregular ' + CASE DEFAULT + RunType( 5:5 ) = 'R' + PlotType = 'rectilin ' + END SELECT + + SELECT CASE ( RunType( 6:6 ) ) + CASE ( '2','3' ) + CASE DEFAULT + RunType( 6:6 ) = '2' + END SELECT + RETURN - END !SUBROUTINE Reflect2D - -END MODULE initenv_mod + END !SUBROUTINE ReadRunType + + !**********************************************************************! +END MODULE init_mod diff --git a/src/ihop_readparms.F b/src/ihop_readparms.F index 64ebf1e..488dc22 100644 --- a/src/ihop_readparms.F +++ b/src/ihop_readparms.F @@ -89,11 +89,13 @@ SUBROUTINE IHOP_READPARMS( myThid ) & ihop_idw_weights, & ihop_ranges +#ifdef ALLOW_COST NAMELIST /IHOP_COST_NML/ & ihopdoncoutput, & ihopObsDir, & ihopObsFiles, & mult_ihop +#endif C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| From 2587230ac053122b9e7062877719d95b1333ee6e Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Thu, 12 Sep 2024 16:46:36 -0500 Subject: [PATCH 04/13] work in timeinv test --- src/ihop_init_fixed_env.F90 | 65 ++++++++++++++++++++++++++++--------- 1 file changed, 50 insertions(+), 15 deletions(-) diff --git a/src/ihop_init_fixed_env.F90 b/src/ihop_init_fixed_env.F90 index aaec812..83c4027 100644 --- a/src/ihop_init_fixed_env.F90 +++ b/src/ihop_init_fixed_env.F90 @@ -1,5 +1,7 @@ #include "IHOP_OPTIONS.h" MODULE init_mod + +IMPLICIT NONE PRIVATE public ihop_init_fixed_env @@ -10,17 +12,21 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) ! =========================================================================== ! USES - IMPLICIT NONE USE bdry_mod, only: Bdry, HSInfo USE srpos_mod, only: Pos, ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec - USE ssp_mod, only: SSP + USE ssp_mod, only: SSP, initSSP USE ihop_mod, only: Beam, rxyz USE angle_mod, only: Angles, ReadRayElevationAngles ! =========================================================================== ! == Global Variables == -#include "IHOP_SIZE.h" -#include "IHOP.h" +#include "SIZE.h" +#include "GRID.h" +#include "EEPARAMS.h" +#ifdef ALLOW_IHOP +# include "IHOP_SIZE.h" +# include "IHOP.h" +#endif ! =========================================================================== ! == Routine Arguments == @@ -29,16 +35,18 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - ! =========================================================================== - ! == Local Variables == - INTEGER :: iAllocStat, ierr - INTEGER :: jj - ! added locally previously read in from unknown mod ... IEsco22 - CHARACTER ( LEN=2 ) :: AttenUnit - INTEGER :: iSeg - INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 - - ! =========================================================================== +!! ! =========================================================================== +!! ! == Local Variables == +!! INTEGER :: iAllocStat, ierr +!! INTEGER :: jj + REAL (KIND=_RL90), PARAMETER :: c0 = 1500.0 + CHARACTER (LEN=2) :: AttenUnit + CHARACTER (LEN=10) :: PlotType + REAL (KIND=_RL90) :: x(2), Depth +!! INTEGER :: iSeg +!! INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 +!! +!! ! =========================================================================== !IESCO24: some notes while I noodle ! Use data.ihop, set time series invariant parameters. These are fixed @@ -58,6 +66,9 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) ! This subroutine will set parameters that shouldn't need to be modified ! throughout the MITgcm model run + ! === Set local parameters === + AttenUnit = '' + ! === Set nonallocatable derived type components from other modules === Bdry%Bot%HS = HSInfo(0.,0.,0.,0., 0.,0. , (0.,0.),(0.,0.), '', '' ) Bdry%Top%HS = HSInfo(0.,0.,0.,0., 0.,0. , (0.,0.),(0.,0.), '', '' ) @@ -409,6 +420,16 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) ! **********************************************************************! SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) USE atten_mod, only: T, Salinity, pH, z_bar, iBio, NBioLayers, bio + USE ssp_mod, only: SSP + + ! =========================================================================== + ! == Global Variables == +#include "SIZE.h" +#include "EEPARAMS.h" +#ifdef ALLOW_IHOP +# include "IHOP_SIZE.h" +# include "IHOP.h" +#endif ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO @@ -494,7 +515,17 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) !**********************************************************************! SUBROUTINE TopBot( AttenUnit, HS, myThid ) ! Handles top and bottom boundary conditions - use atten_mod, only: CRCI + USE atten_mod, only: CRCI + USE bdry_mod, only: HSInfo + + ! =========================================================================== + ! == Global Variables == +#include "SIZE.h" +#include "EEPARAMS.h" +#ifdef ALLOW_IHOP +# include "IHOP_SIZE.h" +# include "IHOP.h" +#endif ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO @@ -585,6 +616,10 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) ! Read the RunType variable and print to .prt file USE srPos_mod, only: Pos + + ! =========================================================================== + ! == Global Variables == +#include "EEPARAMS.h" ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO From 592c5bd2cd522643b0af6a19287136c80303003e Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Fri, 13 Sep 2024 11:21:04 -0500 Subject: [PATCH 05/13] scoping in ssp_mod, modern spline algo, clean initenv --- src/initenvihop.F90 | 1 + src/splinec_mod.F90 | 100 ++++++++------------------------------------ src/ssp_mod.F90 | 65 +++++++++++++++------------- 3 files changed, 54 insertions(+), 112 deletions(-) diff --git a/src/initenvihop.F90 b/src/initenvihop.F90 index 8686398..d2550f4 100644 --- a/src/initenvihop.F90 +++ b/src/initenvihop.F90 @@ -822,6 +822,7 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) ENDIF ! no output on adjoint runs SELECT CASE ( HS%BC ) + CASE ( 'V','R','F','W','P') CASE ( 'A' ) ! *** Half-space properties *** ! IEsco23: MISSING IF BOTTOM BC CHECK zTemp = HS%Depth diff --git a/src/splinec_mod.F90 b/src/splinec_mod.F90 index 85f7393..a3dfb03 100644 --- a/src/splinec_mod.F90 +++ b/src/splinec_mod.F90 @@ -70,11 +70,12 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) ! ********************************************************************** - IMPLICIT INTEGER (I-N) + IMPLICIT INTEGER (I-M) IMPLICIT REAL (KIND=_RL90) (A-H,O-Z) - INTEGER :: NDIM, IBCBEG, IBCEND - REAL (KIND=_RL90) :: TAU(N) - COMPLEX (KIND=_RL90) :: C(4,NDIM), G, DTAU, DIVDF1, DIVDF3 + INTEGER, INTENT(IN) :: N, NDIM, IBCBEG, IBCEND + REAL (KIND=_RL90), INTENT(IN) :: TAU(N) + COMPLEX (KIND=_RL90), INTENT(INOUT) :: C(4,NDIM) + COMPLEX (KIND=_RL90) :: G, DTAU, DIVDF1, DIVDF3 L = N - 1 @@ -182,90 +183,25 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) RETURN END SUBROUTINE CSPLINE - - -!SUBROUTINE VSPLINE (TAU, C, M, MDIM, F, N) -! -! ! VSPLINE CALCULATES THE CUBIC SPLINE VALUES FOR A SET OF N POINTS -! ! IN F FROM THE M-POINT CUBI! SPLINE FIT IN ! AND THE NODES IN TAU. -! ! THE POINTS ARE RETURNED IN F. ALL OF THE POINTS IN F MUST LIE -! ! BETWEEN TAU(1) AND TAU(M). -! -! ! * * * * * * * * * * * * * WARNINGS * * * * * * * * * * * * * -! -! ! POINTS OUTSIDE OF THE SPLINE FIT REGION ARE EXTRAPOLATED FROM THE END -! ! INTERVALS. THIS CAN RESULT IN WILD VALUES IF EXTRAPOLATED TOO FAR. -! ! ALSO THE POINTS MUST BE IN STRICTLY ASCENDING ORDER, IF NOT THE -! ! POINTS WHICH ARE OUT OF ORDER WILL BE EXTRAPOLATED FROM THE CURRENT -! ! INTERVAL AGAIN RESULTING IN WILD VALUES. -! -! IMPLICIT REAL (KIND=_RL90) (A-H,O-Z) -! REAL (KIND=_RL90) :: TAU(M) -! COMPLEX (KIND=_RL90) :: C(4,MDIM), F(N), SPLINE -! -! J = 1 -! DO I = 1,N -!10 J1 = J + 1 -! IF (TAU(J1) < REAL(F(I)) .AND. J1 < M) THEN ! CHECK TO MAKE SURE -! J = J + 1 ! THIS POINT IS NOT -! GO TO 10 ! IN THE NEXT INTERVAL. -! END IF -! H = DBLE (F(I)) - TAU(J) ! DISTANCE FROM START OF INTERVAL -! F(I) = SPLINE (C(1,J), H) -! END DO -! RETURN -!END SUBROUTINE VSPLINE - - -!!**********************************************************************C -! FUNCTION SPLINE ( C, H ) -! -!! THIS FUNCTION EVALUATES THE SPLINE AT THE POINT H -! -! IMPLICIT REAL (KIND=_RL90) ( A-H, O-Z ) -! COMPLEX (KIND=_RL90) C(4), SPLINE -! -! SPLINE = C(1) + H * ( C(2) + H * ( C(3) / 2.0 + H * C(4) / 6.0 ) ) -! RETURN -! END FUNCTION SPLINE -! -! FUNCTION SPLINEX ( C, H ) -! -!! THIS FUNCTION EVALUATES THE SPLINE DERIVATIVE AT THE POINT H -! -! IMPLICIT REAL (KIND=_RL90) ( A-H, O-Z ) -! COMPLEX (KIND=_RL90) :: C(4), SPLINEX -! -! SPLINEX = C(2) + H * ( C(3) + H * C(4) / 2.0 ) -! RETURN -! END FUNCTION SPLINEX -! -! FUNCTION SPLINEXX ( C, H ) -! -!! THIS FUNCTION EVALUATES THE SPLINE 2ND DERIVATIVE AT THE POINT H -! -! IMPLICIT REAL (KIND=_RL90) ( A-H, O-Z ) -! COMPLEX (KIND=_RL90) :: C(4), SPLINEXX -! -! SPLINEXX = C(3) + H * C(4) -! RETURN -! END FUNCTION SPLINEXX -!!**********************************************************************C - SUBROUTINE SPLINEALL ( C, H, F, FX, FXX ) +!**********************************************************************C +SUBROUTINE SPLINEALL ( C, H, F, FX, FXX ) ! THIS ROUTINE EVALUATES THE ! SPLINE, ! SPLINE DERIVATIVE, AND ! SPLINE 2ND DERIVATIVE AT THE POINT H - IMPLICIT REAL (KIND=_RL90) ( A-H, O-Z ) - PARAMETER ( HALF = 0.5, SIXTH = 1.0 / 6.0 ) - COMPLEX (KIND=_RL90) :: C(4), F, FX, FXX + IMPLICIT REAL (KIND=_RL90) ( A-G, O-Z ) + REAL (KIND=_RL90), PARAMETER :: HALF = 0.5, SIXTH = 1.0 / 6.0 + REAL (KIND=_RL90), INTENT(IN) :: H + COMPLEX (KIND=_RL90), INTENT(IN) :: C(4) + COMPLEX (KIND=_RL90), INTENT(OUT) :: F, FX, FXX - F = C(1) + H * ( C(2) + H * ( HALF * C(3) + SIXTH * H * C(4) ) ) - FX = C(2) + H * ( C(3) + H * HALF * C(4) ) - FXX = C(3) + H * C(4) + F = C(1) + H * ( C(2) + H * ( HALF * C(3) + SIXTH * H * C(4) ) ) + FX = C(2) + H * ( C(3) + H * HALF * C(4) ) + FXX = C(3) + H * C(4) + + RETURN +END SUBROUTINE SPLINEALL - RETURN - END SUBROUTINE SPLINEALL END MODULE splinec_mod diff --git a/src/ssp_mod.F90 b/src/ssp_mod.F90 index 0632979..4f452da 100644 --- a/src/ssp_mod.F90 +++ b/src/ssp_mod.F90 @@ -61,6 +61,9 @@ MODULE ssp_mod ! DEFAULT values, BELLHOP only modifies alphaR REAL (KIND=_RL90) :: alphaR = 1500, betaR = 0, alphaI = 0, & betaI = 0, rhoR = 1 + ! SSP interpolation parameters, only used in ssp_mod + COMPLEX (KIND=_RL90) :: n2(MaxSSP), n2z(MaxSSP) + COMPLEX (KIND=_RL90) :: cSpln( 4, MaxSSP ), cCoef( 4, MaxSSP ) ! TYPE STRUCTURES ! == Type Structures == @@ -72,17 +75,14 @@ MODULE ssp_mod TYPE SSPStructure INTEGER :: NPts, Nr, Nx, Ny, Nz REAL (KIND=_RL90) :: z( MaxSSP ), rho( MaxSSP ) - COMPLEX (KIND=_RL90) :: c( MaxSSP ), cz( MaxSSP ), n2( MaxSSP ), & - n2z( MaxSSP ), cSpline( 4, MaxSSP ) - REAL (KIND=_RL90), ALLOCATABLE :: cMat( :, : ), czMat( :, : ) + COMPLEX (KIND=_RL90) :: c( MaxSSP ), cz( MaxSSP ) + REAL (KIND=_RL90), ALLOCATABLE :: cMat( :, : ), czMat( :, : ) #ifdef IHOP_THREED REAL (KIND=_RL90), ALLOCATABLE :: cMat3( :, :, : ), czMat3( :, :, : ) #endif /* IHOP_THREED */ TYPE ( rxyz_vector ) :: Seg CHARACTER (LEN=1) :: Type CHARACTER (LEN=2) :: AttenUnit - ! for PCHIP coefs. - COMPLEX (KIND=_RL90) :: cCoef( 4, MaxSSP ), CSWork( 4, MaxSSP ) END TYPE SSPStructure TYPE( SSPStructure ) :: SSP @@ -116,6 +116,12 @@ SUBROUTINE initSSP( x, myThid ) ! Allocatable arrays !$TAF store ssp%cmat,ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = initssp1 + ! init defaults for ssp_mod scoped arrays + n2 = (-1.,-1.) + n2z = (-1.,-1.) + cSpln = (-1.,-1.) + cCoef = (-1.,-1.) + ! All methods require Depth Depth = x( 2 ) ! Check if SSPFile exists @@ -127,13 +133,13 @@ SUBROUTINE initSSP( x, myThid ) SELECT CASE ( SSP%Type ) CASE ( 'N' ) ! N2-linear profile option - SSP%n2( 1:SSP%NPts ) = 1.0 / SSP%c( 1:SSP%NPts )**2 - !IEsco23 Test this: SSP%n2( 1:SSP%Nz ) = 1.0 / SSP%c( 1:SSP%Nz )**2 + n2( 1:SSP%NPts ) = 1.0 / SSP%c( 1:SSP%NPts )**2 + !IEsco23 Test this: n2( 1:SSP%Nz ) = 1.0 / SSP%c( 1:SSP%Nz )**2 ! compute gradient, n2z DO iz = 2, SSP%Npts - SSP%n2z( iz - 1 ) = ( SSP%n2( iz ) - SSP%n2( iz - 1 ) ) / & - ( SSP%z( iz ) - SSP%z( iz - 1 ) ) + n2z( iz-1 ) = ( n2( iz ) - n2( iz-1 ) ) / & + ( SSP%z( iz ) - SSP%z( iz-1 ) ) END DO CASE ( 'C' ) ! C-linear profile option @@ -141,19 +147,19 @@ SUBROUTINE initSSP( x, myThid ) ! 2 3 ! compute coefficients of std cubic polynomial: c0 + c1*x + c2*x + c3*x ! - CALL PCHIP( SSP%z, SSP%c, SSP%NPts, SSP%cCoef, SSP%CSWork ) + CALL PCHIP( SSP%z, SSP%c, SSP%NPts, cCoef, cSpln ) !IEsco23 Test this: -! CALL PCHIP( SSP%z, SSP%c, SSP%Nz, SSP%cCoef, SSP%CSWork ) +! CALL PCHIP( SSP%z, SSP%c, SSP%Nz, cCoef, cSpln ) CASE ( 'S' ) ! Cubic spline profile option - SSP%cSpline( 1, 1:SSP%NPts ) = SSP%c( 1:SSP%NPts ) + cSpln( 1, 1:SSP%NPts ) = SSP%c( 1:SSP%NPts ) !IEsco23 Test this: -! SSP%cSpline( 1, 1 : SSP%Nz ) = SSP%c( 1 : SSP%Nz ) +! cSpln( 1, 1 : SSP%Nz ) = SSP%c( 1 : SSP%Nz ) ! Compute spline coefs - CALL CSpline( SSP%z, SSP%cSpline( 1, 1 ), SSP%NPts, 0, 0, SSP%NPts ) + CALL cSpline( SSP%z, cSpln( 1, 1 ), SSP%NPts, 0, 0, SSP%NPts ) !IEsco23 Test this: -! CALL CSpline( SSP%z, SSP%cSpline( 1,1 ), SSP%Nz,iBCBeg, iBCEnd, SSP%Nz ) +! CALL CSpline( SSP%z, cSpln( 1,1 ), SSP%Nz,iBCBeg, iBCEnd, SSP%Nz ) CASE ( 'Q' ) ! calculate cz @@ -262,12 +268,12 @@ SUBROUTINE n2Linear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) W = ( x( 2 ) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) - c = REAL( 1.0D0 / SQRT( ( 1.0D0-W ) * SSP%n2( iSegz ) & - + W * SSP%n2( iSegz+1 ) ) ) - cimag = AIMAG( 1.0D0 / SQRT( ( 1.0D0-W ) * SSP%n2( iSegz ) & - + W * SSP%n2( iSegz+1 ) ) ) + c = REAL( 1.0D0 / SQRT( ( 1.0D0-W ) * n2( iSegz ) & + + W * n2( iSegz+1 ) ) ) + cimag = AIMAG( 1.0D0 / SQRT( ( 1.0D0-W ) * n2( iSegz ) & + + W * n2( iSegz+1 ) ) ) - gradc = [ 0.0D0, -0.5D0 * c * c * c * REAL( SSP%n2z( iSegz ) ) ] + gradc = [ 0.0D0, -0.5D0 * c * c * c * REAL( n2z( iSegz ) ) ] crr = 0.0d0 crz = 0.0d0 czz = 3.0d0 * gradc( 2 ) * gradc( 2 ) / c @@ -351,22 +357,22 @@ SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) END IF xt = x( 2 ) - SSP%z( iSegz ) - c_cmplx = SSP%cCoef( 1, iSegz ) & - + ( SSP%cCoef( 2, iSegz ) & - + ( SSP%cCoef( 3, iSegz ) & - + SSP%cCoef( 4, iSegz ) * xt ) * xt ) * xt + c_cmplx = cCoef( 1, iSegz ) & + + ( cCoef( 2, iSegz ) & + + ( cCoef( 3, iSegz ) & + + cCoef( 4, iSegz ) * xt ) * xt ) * xt c = REAL( c_cmplx ) cimag = AIMAG( c_cmplx ) gradc = [ 0.0D0, & - REAL( SSP%cCoef( 2, iSegz ) + ( 2.0D0 * SSP%cCoef( 3, iSegz ) & - + 3.0D0 * SSP%cCoef( 4, iSegz ) * xt ) * xt ) ] + REAL( cCoef( 2, iSegz ) + ( 2.0D0 * cCoef( 3, iSegz ) & + + 3.0D0 * cCoef( 4, iSegz ) * xt ) * xt ) ] crr = 0.0D0 crz = 0.0D0 - czz = REAL( 2.0D0 * SSP%cCoef( 3, iSegz ) + & - 6.0D0 * SSP%cCoef( 4, iSegz ) * xt ) ! dgradc(2)/dxt + czz = REAL( 2.0D0 * cCoef( 3, iSegz ) + & + 6.0D0 * cCoef( 4, iSegz ) * xt ) ! dgradc(2)/dxt W = ( x( 2 ) - SSP%z( iSegz ) ) / & ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) @@ -412,8 +418,7 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) hSpline = x( 2 ) - SSP%z( iSegz ) - CALL SplineALL( SSP%cSpline( 1, iSegz ), hSpline, & - c_cmplx, cz_cmplx, czz_cmplx ) + CALL SplineALL( cSpln( 1, iSegz ), hSpline, c_cmplx, cz_cmplx, czz_cmplx ) c = DBLE( c_cmplx ) cimag = AIMAG( c_cmplx ) From 62ca161f7b0fbb9290c2b7a5919ddac996dc262b Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Fri, 13 Sep 2024 15:52:43 -0500 Subject: [PATCH 06/13] sumweights to aCOMMON block --- inc/IHOP.h | 3 ++- src/ihop_init_fixed.F | 6 ++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/inc/IHOP.h b/inc/IHOP.h index 75222d9..e95cc43 100644 --- a/inc/IHOP.h +++ b/inc/IHOP.h @@ -105,13 +105,14 @@ _RS ihop_xc ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) _RS ihop_yc ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) _RL ihop_ranges ( IHOP_MAX_NC_SIZE ) + _RL ihop_sumweights ( IHOP_NPTS_RANGE, NR ) COMMON /IHOP_PARAMS_R/ & & IHOP_dumpfreq, & & IHOP_freq, IHOP_depth, IHOP_bcsound, IHOP_bcsoundshear, & & ihop_brho, IHOP_bcsoundI, IHOP_bcsoundshearI, & & IHOP_sd, IHOP_rd, IHOP_rr, IHOP_alpha, IHOP_step, & - & ihop_yc, ihop_xc, ihop_idw_weights, ihop_ranges + & ihop_yc, ihop_xc, ihop_idw_weights, ihop_ranges, ihop_sumweights #ifdef IHOP_3D_STATE diff --git a/src/ihop_init_fixed.F b/src/ihop_init_fixed.F index 9f6227d..7856a7d 100644 --- a/src/ihop_init_fixed.F +++ b/src/ihop_init_fixed.F @@ -133,6 +133,12 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) C Only do I/O if in the main thread _END_MASTER( myThid ) +C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| + DO k = 1,Nr + DO i=1,IHOP_npts_range + ihop_sumweights(i,k) = -1.0 + END DO + END DO C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| #ifdef ALLOW_MNC From aa81a5578b14a427c6f15955bce0b573a7fc584e Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 11:33:07 -0500 Subject: [PATCH 07/13] clean up headers --- src/angle_mod.F90 | 33 +-------------------------------- src/bdry_mod.F90 | 8 ++++++++ src/beampattern.F90 | 2 +- src/bellhop.F90 | 4 +--- src/ihop_check.F | 1 + src/srpos_mod.F90 | 1 + src/ssp_mod.F90 | 2 +- 7 files changed, 14 insertions(+), 37 deletions(-) diff --git a/src/angle_mod.F90 b/src/angle_mod.F90 index 07e53ce..432ef6b 100644 --- a/src/angle_mod.F90 +++ b/src/angle_mod.F90 @@ -6,7 +6,6 @@ MODULE angle_mod ! Ivana Escobar ! - USE ihop_mod, only: PRTFile USE subTab_mod, only: SubTab USE srPos_mod, only: Pos USE sort_mod, only: Sort @@ -118,37 +117,6 @@ SUBROUTINE ReadRayElevationAngles( Depth, TopOpt, RunType, myThid ) Angles%alpha(1), 360.0 ) ) < 10.0*TINY(1.0D0) ) & Angles%Nalpha = Angles%Nalpha - 1 -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(2A)')'_____________________________________________', & - '______________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,I10)') 'Number of beams in elevation = ', & - Angles%Nalpha - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - IF ( Angles%iSingle_alpha > 0 ) THEN - WRITE(msgBuf,'(A,I10)') 'Trace only beam number ', & - Angles%iSingle_alpha - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - WRITE(msgBuf,'(A)') 'Beam take-off angles (degrees)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - - IF ( Angles%Nalpha >= 1 ) THEN - WRITE(msgBuf,'(10F12.3)') & - Angles%alpha( 1:MIN(Angles%Nalpha,Number_to_Echo) ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - IF ( Angles%Nalpha > Number_to_Echo ) THEN - WRITE(msgBuf,'(A,F12.6)') ' ... ', Angles%alpha( Angles%Nalpha ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - ENDIF -#endif /* IHOP_WRITE_OUT */ - IF ( Angles%Nalpha>1 .AND. & Angles%alpha(Angles%Nalpha) == Angles%alpha(1) ) THEN #ifdef IHOP_WRITE_OUT @@ -177,6 +145,7 @@ SUBROUTINE ReadRayElevationAngles( Depth, TopOpt, RunType, myThid ) !**********************************************************************! #ifdef IHOP_THREED SUBROUTINE ReadRayBearingAngles( TopOpt, RunType, myThid ) + USE ihop_mod, only: PRTFile ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO diff --git a/src/bdry_mod.F90 b/src/bdry_mod.F90 index f97779e..66e4ea7 100644 --- a/src/bdry_mod.F90 +++ b/src/bdry_mod.F90 @@ -520,6 +520,14 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) Bot(:)%x(1) = 1000.0 * Bot(:)%x(1) ! Convert ranges in km to m +# ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)')'_____________________________________________', & + '______________' + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +# endif /* IHOP_WRITE_OUT */ + CASE DEFAULT ! no bathymetry given, use SSP depth for flat bottom # ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(A)') 'No BTYFile; assuming flat bottom' diff --git a/src/beampattern.F90 b/src/beampattern.F90 index a2a1fa7..6f56df9 100644 --- a/src/beampattern.F90 +++ b/src/beampattern.F90 @@ -13,9 +13,9 @@ MODULE beamPattern IMPLICIT NONE ! == Global variables == #include "SIZE.h" +#include "GRID.h" #include "EEPARAMS.h" #include "PARAMS.h" -#include "GRID.h" #include "IHOP_SIZE.h" #include "IHOP.h" diff --git a/src/bellhop.F90 b/src/bellhop.F90 index da47d62..896eef6 100644 --- a/src/bellhop.F90 +++ b/src/bellhop.F90 @@ -32,7 +32,6 @@ MODULE BELLHOP USE angle_mod, only: Angles, ialpha USE srPos_mod, only: Pos USE ssp_mod, only: evalSSP, SSP - !HSInfo, Bdry, USE bdry_mod, only: initATI, initBTY, GetTopSeg, GetBotSeg, Bot, Top, & atiType, btyType, IsegTop, IsegBot, & rTopSeg, rBotSeg, Bdry @@ -174,7 +173,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: failed allocation Pos%theta' CALL PRINT_ERROR( msgBuf, myThid ) #endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R IHOP_INIT' + STOP 'ABNORMAL END: S/R IHOP_INIT' ENDIF Pos%theta( 1 ) = 0. @@ -259,7 +258,6 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. !#ifdef ALLOW_COST ! ! Broadcast info to all MPI procs for COST function accumulation -! print *, "escobar: broacasting from pid ", myProcId ! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) ! !#endif /* ALLOW_COST */ diff --git a/src/ihop_check.F b/src/ihop_check.F index f89892d..8556743 100644 --- a/src/ihop_check.F +++ b/src/ihop_check.F @@ -13,6 +13,7 @@ SUBROUTINE IHOP_CHECK( myThid ) C !USES: IMPLICIT NONE #include "SIZE.h" +#include "GRID.h" #include "EEPARAMS.h" #include "PARAMS.h" #include "IHOP_SIZE.h" diff --git a/src/srpos_mod.F90 b/src/srpos_mod.F90 index 2eb9855..e475111 100644 --- a/src/srpos_mod.F90 +++ b/src/srpos_mod.F90 @@ -16,6 +16,7 @@ MODULE srpos_mod IMPLICIT NONE ! == Global variables == #include "SIZE.h" +#include "GRID.h" #include "EEPARAMS.h" #include "PARAMS.h" #include "IHOP_SIZE.h" diff --git a/src/ssp_mod.F90 b/src/ssp_mod.F90 index 4f452da..22301f8 100644 --- a/src/ssp_mod.F90 +++ b/src/ssp_mod.F90 @@ -125,7 +125,7 @@ SUBROUTINE initSSP( x, myThid ) ! All methods require Depth Depth = x( 2 ) ! Check if SSPFile exists - IF (useSSPFile .EQV. .TRUE.) THEN + IF (useSSPFile) THEN CALL ReadSSP( Depth, myThid ) ELSE CALL ExtractSSP(Depth, myThid ) From 39d0064a6705ea1b2a0e5d2e4359e51f8d761895 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 11:36:06 -0500 Subject: [PATCH 08/13] correct ihop.h --- inc/IHOP.h | 2 +- mitgcm_code/IHOP_SIZE.h | 2 +- src/ihop_init_fixed_env.F90 | 30 +++++++++++------------------- 3 files changed, 13 insertions(+), 21 deletions(-) diff --git a/inc/IHOP.h b/inc/IHOP.h index e95cc43..9395efa 100644 --- a/inc/IHOP.h +++ b/inc/IHOP.h @@ -105,7 +105,7 @@ _RS ihop_xc ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) _RS ihop_yc ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) _RL ihop_ranges ( IHOP_MAX_NC_SIZE ) - _RL ihop_sumweights ( IHOP_NPTS_RANGE, NR ) + _RL ihop_sumweights ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) COMMON /IHOP_PARAMS_R/ & & IHOP_dumpfreq, & diff --git a/mitgcm_code/IHOP_SIZE.h b/mitgcm_code/IHOP_SIZE.h index 945a24e..8d140a8 100644 --- a/mitgcm_code/IHOP_SIZE.h +++ b/mitgcm_code/IHOP_SIZE.h @@ -55,7 +55,7 @@ ! Number of interpolation points: ! ================================ INTEGER IHOP_MAX_NC_SIZE - PARAMETER ( IHOP_MAX_NC_SIZE = 10 ) + PARAMETER ( IHOP_MAX_NC_SIZE = 15 ) ! INTEGER IHOP_NPTS_RANGE ! PARAMETER( IHOP_NPTS_RANGE = 6 ) ! INTEGER IHOP_IDW_NPTS diff --git a/src/ihop_init_fixed_env.F90 b/src/ihop_init_fixed_env.F90 index 83c4027..b3749c9 100644 --- a/src/ihop_init_fixed_env.F90 +++ b/src/ihop_init_fixed_env.F90 @@ -14,7 +14,7 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) ! USES USE bdry_mod, only: Bdry, HSInfo USE srpos_mod, only: Pos, ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec - USE ssp_mod, only: SSP, initSSP + USE ssp_mod, only: SSP, initSSP, alphar USE ihop_mod, only: Beam, rxyz USE angle_mod, only: Angles, ReadRayElevationAngles @@ -37,14 +37,10 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) !! ! =========================================================================== !! ! == Local Variables == -!! INTEGER :: iAllocStat, ierr -!! INTEGER :: jj REAL (KIND=_RL90), PARAMETER :: c0 = 1500.0 CHARACTER (LEN=2) :: AttenUnit CHARACTER (LEN=10) :: PlotType REAL (KIND=_RL90) :: x(2), Depth -!! INTEGER :: iSeg -!! INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 !! !! ! =========================================================================== @@ -90,11 +86,6 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) SSP%z = -1. SSP%rho = -1. SSP%c = -1. - SSP%n2 = -1. - SSP%n2z = -1. - SSP%cSpline = -1. - SSP%cCoef = (-1.,-1.) - SSP%cSWork = (-1.,-1.) SSP%Type = '' SSP%AttenUnit = '' @@ -136,8 +127,7 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) CALL TopBot( AttenUnit, Bdry%Bot%HS, myThid ) SELECT CASE ( Bdry%Bot%HS%Opt( 2:2 ) ) - CASE( '~', '*' ) - CASE( ' ' ) + CASE( '~', '*', ' ' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(A)') 'INITENVIHOP initEnv: Unknown Bdry%Bot%HS%Opt(2)' @@ -172,6 +162,9 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) Pos%NRr = IHOP_nrr CALL AllocatePos( Pos%NRr, Pos%Rr, IHOP_rr ) CALL ReadRcvrRanges( myThid ) +#ifdef IHOP_THREED + CALL ReadRcvrBearings( myThid ) +#endif /* IHOP_THREED */ ! *** Broadband frequencies *** @@ -182,6 +175,9 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) Beam%RunType = IHOP_runopt CALL ReadRunType( Beam%RunType, PlotType, myThid ) CALL ReadRayElevationAngles( Depth, Bdry%Top%HS%Opt, Beam%RunType, myThid ) +#ifdef IHOP_THREED + CALL ReadRayBearingAngles( Bdry%Top%HS%Opt, Beam%RunType, myThid ) +#endif /* IHOP_THREED */ ! *** Acoustic grid *** @@ -359,7 +355,6 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) !! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. !!#ifdef ALLOW_COST !! ! Broadcast info to all MPI procs for COST function accumulation -!! print *, "escobar: broacasting from pid ", myProcId !! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) !! !!#endif /* ALLOW_COST */ @@ -415,7 +410,7 @@ SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) !#endif /* IHOP_WRITE_OUT */ RETURN - END !SUBROUTINE IHOP_INIT + END !SUBROUTINE ! **********************************************************************! SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) @@ -517,6 +512,7 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) ! Handles top and bottom boundary conditions USE atten_mod, only: CRCI USE bdry_mod, only: HSInfo + USE ssp_mod, only: alphaR, betaR, alphaI, betaI, rhoR ! =========================================================================== ! == Global Variables == @@ -538,9 +534,6 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) TYPE ( HSInfo ), INTENT( INOUT ) :: HS REAL (KIND=_RL90) :: Mz, vr, alpha2_f ! values related to grain size REAL (KIND=_RL90) :: ztemp, bPower, fT - ! FROM SSP_MOD.F90 - REAL (KIND=_RL90) :: alphaR = 1500., betaR = 0., alphaI = 0., & - betaI = 0., rhoR = 1. ! ! ****** Read in BC parameters depending on particular choice ****** ! HS%cp = 0.0 @@ -680,6 +673,5 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) RETURN END !SUBROUTINE ReadRunType - - !**********************************************************************! +!**********************************************************************! END MODULE init_mod From 534111cc20b3b50eaeb844e96354e0fc5af84495 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 14:51:15 -0500 Subject: [PATCH 09/13] init fixed; segmented write to PRTFile --- src/bellhop.F90 | 269 ++++---- src/ihop_init_diag.F90 | 1005 +++++++++++++++++++++++++++++ src/ihop_init_fixed.F | 6 +- src/initenvihop.F90 | 1378 ---------------------------------------- src/srpos_mod.F90 | 309 ++++++--- src/ssp_mod.F90 | 744 +++++++++++----------- 6 files changed, 1727 insertions(+), 1984 deletions(-) create mode 100644 src/ihop_init_diag.F90 delete mode 100644 src/initenvihop.F90 diff --git a/src/bellhop.F90 b/src/bellhop.F90 index 896eef6..129984e 100644 --- a/src/bellhop.F90 +++ b/src/bellhop.F90 @@ -28,7 +28,6 @@ MODULE BELLHOP USE ihop_mod, only: rad2deg, i, Beam, ray2D, NRz_per_range, afreq, & SrcDeclAngle, iSmallStepCtr, & PRTFile, SHDFile, ARRFile, RAYFile, DELFile - USE initenvihop, only: initEnv, openOutputFiles, resetMemory USE angle_mod, only: Angles, ialpha USE srPos_mod, only: Pos USE ssp_mod, only: evalSSP, SSP @@ -52,7 +51,6 @@ MODULE BELLHOP #include "SIZE.h" #include "GRID.h" #include "EEPARAMS.h" -#include "EESUPPORT.h" #include "PARAMS.h" #include "IHOP_SIZE.h" #include "IHOP.h" @@ -66,7 +64,9 @@ MODULE BELLHOP CONTAINS SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) - ! !INPUT/OUTPUT PARAMETERS: + USE ihop_init_diag, only: initPRTFile, openOutputFiles, resetMemory + USE ssp_mod, only: setSSP + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. @@ -76,86 +76,55 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - INTEGER :: iostat, iAllocStat, ierr - INTEGER :: jj + INTEGER :: iAllocStat REAL :: Tstart, Tstop - ! added locally previously read in from unknown mod ... IEsco22 - CHARACTER ( LEN=2 ) :: AttenUnit - ! For MPI writing: inspo from eeboot_minimal.F - CHARACTER*(MAX_LEN_FNAM) :: fNam - CHARACTER*(6) :: fmtStr - INTEGER :: mpiRC, IL + REAL (KIND=_RL90) :: x(2) ! =========================================================================== - INTEGER :: iSeg INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 ! =========================================================================== -!$TAF init ihop_init1 = 'BellhopIhop_init' - - ! Open the print file: template from eeboot_minimal.F -#ifdef IHOP_WRITE_OUT - IF ( .NOT.usingMPI ) THEN - WRITE(myProcessStr, '(I10.10)') myIter - IL=ILNBLNK( myProcessStr ) - WRITE(fNam,'(4A)') TRIM(IHOP_fileroot),'.',myProcessStr(1:IL),'.prt' - IF ( IHOP_dumpfreq.GE.0 ) & - OPEN( PRTFile, FILE = fNam, STATUS = 'UNKNOWN', IOSTAT = iostat ) -#ifdef ALLOW_USE_MPI - ELSE ! using MPI - CALL MPI_COMM_RANK( MPI_COMM_MODEL, mpiMyId, mpiRC ) - myProcId = mpiMyId - IL = MAX(4,1+INT(LOG10(DFLOAT(nPx*nPy)))) - WRITE(fmtStr,'(2(A,I1),A)') '(I',IL,'.',IL,')' - WRITE(myProcessStr,fmtStr) myProcId - IL = ILNBLNK( myProcessStr ) - mpiPidIo = myProcId - pidIO = mpiPidIo - - IF( mpiPidIo.EQ.myProcId ) THEN -# ifdef SINGLE_DISK_IO - IF( myProcId.eq.0 ) THEN -# endif - IF (myIter.GE.0) THEN - WRITE(fNam,'(4A,I10.10,A)') & - TRIM(IHOP_fileroot),'.',myProcessStr(1:IL),'.',myIter,'.prt' - ELSE - WRITE(fNam,'(4A)') & - TRIM(IHOP_fileroot),'.',myProcessStr(1:IL),'.prt' - ENDIF +!!$TAF init ihop_init1 = 'BellhopIhop_init' +! +!! IESCO24: Write derived type with allocatable memory by type: Pos from srpos_mod +!! Scalar components +!! Allocatable arrays +!!$TAF store pos%wr,pos%ws = ihop_init1 +! +!! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +!! Scalar components +!! Fixed arrays +!!$TAF store ssp%z = ihop_init1 +!! Allocatable arrays +!!$TAF store ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = ihop_init1 - IF ( IHOP_dumpfreq .GE. 0) & - OPEN(PRTFile, FILE=fNam, STATUS='UNKNOWN', IOSTAT=iostat ) - IF ( iostat /= 0 ) THEN - WRITE(*,*) 'ihop: IHOP_fileroot not recognized, ', & - TRIM(IHOP_fileroot) - WRITE(msgBuf,'(A)') 'IHOP_INIT: Unable to recognize file' - CALL PRINT_ERROR( msgBuf, myThid ) - STOP 'ABNORMAL END: S/R IHOP_INIT' - END IF -# ifdef SINGLE_DISK_IO - END IF -# endif - END IF -# endif /* ALLOW_USE_MPI */ - END IF -#endif /* IHOP_WRITE_OUT */ + ! Reset memory + CALL resetMemory() + ! save data.ihop, open PRTFile: REQUIRED + CALL initPRTFile( myTime, myIter, myThid ) -! IESCO24: Write derived type with allocatable memory by type: Pos from srpos_mod -! Scalar components -! Allocatable arrays -!$TAF store pos%wr,pos%ws = ihop_init1 +!!! FROM old initenvihop.F90:initEnv +!! IESCO24: Write derived type with allocatable memory by type: Bdry from bdry_mod +!! Scalar components +!!$TAF store bdry%top%hs%depth,bdry%top%hs%bc = initEnv1 +! +!!$TAF init initEnv1 = 'initenvihop_initenv' +! +!! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +!! Scalar components +!! Fixed arrays +!! Allocatable arrays +!!$TAF store ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = initEnv1 +! +!! IESCO24: Write derived type with allocatable memory by type: Pos from srpos_mod +!! Scalar components +!! Allocatable arrays +!!$TAF store pos%rr = initEnv1 +!!$TAF store pos%theta,pos%wr,pos%ws = initEnv1 -! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod -! Scalar components -! Fixed arrays -!$TAF store ssp%z = ihop_init1 -! Allocatable arrays -!$TAF store ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = ihop_init1 + ! set SSP%cmat from gcm SSP: REQUIRED + x = [ 0.0 _d 0, Bdry%Bot%HS%Depth ] + CALL setSSP( x, myThid ) - ! Reset memory - CALL resetMemory() - ! save data.ihop, gcm SSP: REQUIRED - CALL initEnv( myTime, myIter, myThid ) ! AlTImetry: OPTIONAL, default is no ATIFile CALL initATI( Bdry%Top%HS%Opt( 5:5 ), Bdry%Top%HS%Depth, myThid ) ! BaThYmetry: OPTIONAL, default is BTYFile @@ -166,6 +135,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ! Source Beam Pattern: OPTIONAL, default is omni source pattern SBPFlag = Beam%RunType( 3:3 ) CALL readPat( myThid ) + Pos%Ntheta = 1 ALLOCATE( Pos%theta( Pos%Ntheta ), Stat = IAllocStat ) IF ( IAllocStat/=0 ) THEN @@ -177,8 +147,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ENDIF Pos%theta( 1 ) = 0. - -! Allocate arrival and U variables on all MPI processes + ! Allocate arrival and U variables on all MPI processes SELECT CASE ( Beam%RunType( 5:5 ) ) CASE ( 'I' ) NRz_per_range = 1 ! irregular grid @@ -186,59 +155,63 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) NRz_per_range = Pos%NRz ! rectilinear grid END SELECT - IF ( ALLOCATED( U ) ) DEALLOCATE( U ) - SELECT CASE ( Beam%RunType( 1:1 ) ) - ! for a TL calculation, allocate space for the pressure matrix - CASE ( 'C', 'S', 'I' ) ! TL calculation - ALLOCATE ( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) - IF ( iAllocStat/=0 ) THEN + SELECT CASE ( Beam%RunType( 1:1 ) ) + ! for a TL calculation, allocate space for the pressure matrix + CASE ( 'C', 'S', 'I' ) ! TL calculation + ALLOCATE( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) + IF ( iAllocStat/=0 ) THEN #ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & 'Insufficient memory for TL matrix: reduce Nr*NRz' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R IHOP_INIT' - END IF - U = 0.0 ! init default value - CASE ( 'A', 'a', 'R', 'E', 'e' ) ! Arrivals calculation - ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable - U( 1,1 ) = 0. ! init default value - CASE DEFAULT - ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable - U( 1,1 ) = 0. ! init default value - END SELECT - - ! for an arrivals run, allocate space for arrivals matrices - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'A', 'a', 'e' ) - ! allow space for at least MinNArr arrivals - MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & - MinNArr ) - ALLOCATE ( Arr( MaxNArr, Pos%NRr, NRz_per_range ), & - NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) - IF ( iAllocStat /= 0 ) THEN + STOP 'ABNORMAL END: S/R IHOP_INIT' + END IF + U = 0.0 ! init default value + CASE ( 'A', 'a', 'R', 'E', 'e' ) ! Arrivals calculation + ALLOCATE( U( 1,1 ) ) ! open a dummy variable + U( 1,1 ) = 0. ! init default value + CASE DEFAULT + ALLOCATE( U( 1,1 ) ) ! open a dummy variable + U( 1,1 ) = 0. ! init default value + END SELECT + + ! for an arrivals run, allocate space for arrivals matrices + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'A', 'a', 'e' ) + ! allow space for at least MinNArr arrivals + MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & + MinNArr ) + CASE DEFAULT + MaxNArr = 1 + END SELECT + + ! init Arr, Narr + ALLOCATE( Arr( MaxNArr, Pos%NRr, NRz_per_range ), & + NArr(Pos%NRr, NRz_per_range), STAT = iAllocStat ) + IF ( iAllocStat /= 0 ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & - 'Not enough allocation for Arr; reduce ArrivalsStorage' - CALL PRINT_ERROR( msgBuf,myThid ) + WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & + 'Not enough allocation for Arr; reduce ArrivalsStorage' + CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R IHOP_INIT' - END IF - CASE DEFAULT - MaxNArr = 1 - ALLOCATE ( Arr( 1, NRz_per_range, Pos%NRr ), & - NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) - END SELECT - - ! init Arr, Narr - ! Arr = something - NArr( 1:Pos%NRr, 1:NRz_per_range ) = 0 ! IEsco22 unnecessary? NArr = 0 below + STOP 'ABNORMAL END: S/R IHOP_INIT' + END IF + + NArr = 0 + Arr(:,:,:)%NTopBnc = -1 + Arr(:,:,:)%NBotBnc = -1 + Arr(:,:,:)%SrcDeclAngle = -999. + Arr(:,:,:)%RcvrDeclAngle = -999. + Arr(:,:,:)%A = -999. + Arr(:,:,:)%Phase = -999. + Arr(:,:,:)%delay = -999. #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) + WRITE(msgBuf,'(A)') + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) & + CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) #endif /* IHOP_WRITE_OUT */ @@ -284,31 +257,31 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) ! close all files - IF ( IHOP_dumpfreq .GE. 0) THEN - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'C', 'S', 'I' ) ! TL calculation - CLOSE( SHDFile ) - CASE ( 'A', 'a' ) ! arrivals calculation - CLOSE( ARRFile ) - CASE ( 'R', 'E' ) ! ray and eigen ray trace - CLOSE( RAYFile ) - CASE ( 'e' ) - CLOSE( RAYFile ) - CLOSE( ARRFile ) - IF ( writeDelay ) CLOSE( DELFile ) - END SELECT - - if (numberOfProcs.gt.1) then - ! Erase prtfiles that aren't on procid = 0 - if(myProcId.ne.0) then - CLOSE(PRTFile, STATUS='DELETE') - else - CLOSE(PRTFile) - endif + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'C', 'S', 'I' ) ! TL calculation + CLOSE( SHDFile ) + CASE ( 'A', 'a' ) ! arrivals calculation + CLOSE( ARRFile ) + CASE ( 'R', 'E' ) ! ray and eigen ray trace + CLOSE( RAYFile ) + IF ( writeDelay ) CLOSE( DELFile ) + CASE ( 'e' ) + CLOSE( RAYFile ) + CLOSE( ARRFile ) + IF ( writeDelay ) CLOSE( DELFile ) + END SELECT + + if (numberOfProcs.gt.1) then + ! Erase prtfiles that aren't on procid = 0 + if(myProcId.ne.0) then + CLOSE(PRTFile, STATUS='DELETE') else CLOSE(PRTFile) endif - ENDIF + else + CLOSE(PRTFile) + endif + ENDIF #endif /* IHOP_WRITE_OUT */ @@ -317,8 +290,8 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ! **********************************************************************! SUBROUTINE BellhopCore( myThid ) - USE ssp_mod, only: iSegr !RG -! USE influence, only: ratio1, rB !RG + USE ssp_mod, only: iSegr !RG +! USE influence, only: ratio1, rB !RG ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. @@ -326,10 +299,10 @@ SUBROUTINE BellhopCore( myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - INTEGER :: IBPvec( 1 ), ibp, is, iBeamWindow2, Irz1, Irec, & - NalphaOpt - REAL (KIND=_RL90) :: Amp0, DalphaOpt, xs( 2 ), RadMax, s, & - c, cimag, gradc( 2 ), crr, crz, czz, rho + INTEGER :: IBPvec(1), ibp, is, iBeamWindow2, Irz1, Irec, & + NalphaOpt + REAL (KIND=_RL90) :: Amp0, DalphaOpt, xs(2), RadMax, s, & + c, cimag, gradc(2), crr, crz, czz, rho !$TAF init BellhopCore1 = static, Pos%NSz !$TAF init BellhopCore2 = static, Pos%NSz*Angles%Nalpha diff --git a/src/ihop_init_diag.F90 b/src/ihop_init_diag.F90 new file mode 100644 index 0000000..72a05a9 --- /dev/null +++ b/src/ihop_init_diag.F90 @@ -0,0 +1,1005 @@ +#include "IHOP_OPTIONS.h" +!BOP +! !INTERFACE: +MODULE IHOP_INIT_DIAG +! +! Ivana Escobar +! + + ! mbp 12/2018, based on much older subroutine + + USE ssp_mod, only: initSSP, SSP + USE bdry_mod, only: Bdry, HSInfo + USE atten_mod, only: CRCI + +! ! USES + implicit none +! == Global variables == +#include "SIZE.h" +#include "GRID.h" +#include "EEPARAMS.h" +#include "EESUPPORT.h" +#include "PARAMS.h" +#include "IHOP_SIZE.h" +#include "IHOP.h" +#ifdef ALLOW_CAL +#include "cal.h" +#endif /* ALLOW_CAL */ + + PRIVATE + +! == Public Interfaces == +!======================================================================= + public initPRTFile, OpenOutputFiles, resetMemory +!======================================================================= + +! INPUT/OUTPUT PARAMETERS: + +! == External Functions == + INTEGER ILNBLNK + EXTERNAL ILNBLNK + +CONTAINS + SUBROUTINE initPRTFile( myTime, myIter, myThid ) + USE ihop_mod, only: PRTFile, Beam + USE angle_mod, only: Angles + USE srpos_mod, only: WriteSxSy, WriteSzRz, WriteRcvrRanges, WriteFreqVec + + ! I/O routine for acoustic fixed inputS + + ! == Routine Arguments == + ! myTime :: Current time in simulation + ! myIter :: Current time-step number + ! myThid :: my Thread Id number + ! msgBuf :: Used to build messages for printing. + _RL, INTENT(IN) :: myTime + INTEGER, INTENT(IN) :: myIter, myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + INTEGER, PARAMETER :: Number_to_Echo = 10 +! REAL (KIND=_RL90), PARAMETER :: c0 = 1500.0 +! REAL (KIND=_RL90) :: x(2), c, cimag, gradc(2), crz, czz, rho, Depth + REAL (KIND=_RL90) :: ranges +! CHARACTER (LEN=10) :: PlotType + + ! *** ihop info to PRTFile *** + CALL openPRTFile( myTime, myIter, myThid ) + +#ifdef IHOP_WRITE_OUT + ! Only do I/O in the main thread + _BEGIN_MASTER(myThid) + + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) THEN + CALL WriteRunType( Beam%RunType, myThid ) + + CALL WriteTopOpt( myThid ) + + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,F10.2,A)' ) 'Depth = ',Bdry%Bot%HS%Depth,' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)') 'Top options: ', Bdry%Top%HS%Opt + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + CALL WriteTopBot( Bdry%Top%HS, myThid ) + + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)') 'Bottom options: ', Bdry%Bot%HS%Opt + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + SELECT CASE ( Bdry%Bot%HS%Opt( 2 : 2 ) ) + CASE ( '~', '*' ) + WRITE(msgBuf,'(A)') ' Bathymetry file selected' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE( ' ' ) + CASE DEFAULT + END SELECT + + CALL WriteTopBot( Bdry%Bot%HS, myThid ) + + + CALL WriteSxSy( myThid ) + CALL WriteSzRz( Bdry%Top%HS%Depth, Bdry%Bot%HS%Depth, myThid ) + CALL WriteRcvrRanges( myThid ) +#ifdef IHOP_THREED + CALL WriteRcvrBearings( myThid ) +#endif + CALL WriteFreqVec( Bdry%Top%HS%Opt( 6:6 ), myThid ) + + + WRITE(msgBuf,'(2A)')'_____________________________________________', & + '______________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,I10)') 'Number of beams in elevation = ', & + Angles%Nalpha + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + IF ( Angles%iSingle_alpha > 0 ) THEN + WRITE(msgBuf,'(A,I10)') 'Trace only beam number ', & + Angles%iSingle_alpha + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF + + WRITE(msgBuf,'(A)') 'Beam take-off angles (degrees)' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + IF ( Angles%Nalpha >= 1 ) THEN + WRITE(msgBuf,'(10F12.3)') & + Angles%alpha( 1:MIN(Angles%Nalpha,Number_to_Echo) ) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF + IF ( Angles%Nalpha > Number_to_Echo ) THEN + WRITE(msgBuf,'(A,F12.6)') ' ... ', Angles%alpha( Angles%Nalpha ) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF + + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)')'______________________________________________', & + '_____________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,G11.4,A)') & + ' Step length, deltas = ', Beam%deltas, ' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + +#ifdef IHOP_THREED + WRITE(msgBuf,'(A,G11.4,A)') & + ' Maximum ray x-range, Box%X = ', Beam%Box%X,' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,G11.4,A)') & + ' Maximum ray y-range, Box%Y = ', Beam%Box%Y,' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,G11.4,A)') & + ' Maximum ray z-range, Box%Z = ', Beam%Box%Z,' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +#else /* not IHOP_THREED */ + ranges = Beam%Box%R / 1000.0 + WRITE(msgBuf,'(A,G11.4,A)') & + ' Maximum ray range, Box%R = ', ranges,' km' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,G11.4,A)') & + ' Maximum ray depth, Box%Z = ', Beam%Box%Z,' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +#endif /* not IHOP_THREED */ + + SELECT CASE ( Beam%Type( 4:4 ) ) + CASE ( 'S' ) + WRITE(msgBuf,'(A)') ' Beam shift in effect' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + WRITE(msgBuf,'(A)') ' No beam shift in effect' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END SELECT + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + ENDIF ! adjoint run check + + ! Only do I/O in the main thread + _END_MASTER(myThid) +#endif /* IHOP_WRITE_OUT */ + + RETURN + END !SUBROUTINE initPRTFile + + !**********************************************************************! + + SUBROUTINE WriteTopOpt( myThid ) + USE ihop_mod, only: PRTFile + USE ssp_mod, only: SSP + USE atten_mod, only: T, Salinity, pH, z_bar, iBio, NBioLayers, bio + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + CHARACTER (LEN= 1) :: BC ! Boundary condition type + + BC = IHOP_TopOpt( 2:2 ) + + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.LT.0) RETURN + +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') 'Interior options: ' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + ! SSP approximation options + SELECT CASE ( SSP%Type ) + CASE ( 'N' ) + WRITE(msgBuf,'(A)') ' N2-linear approximation to SSP' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'C' ) + WRITE(msgBuf,'(A)') ' C-linear approximation to SSP' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'P' ) + WRITE(msgBuf,'(A)') ' PCHIP approximation to SSP' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'S' ) + WRITE(msgBuf,'(A)') ' Spline approximation to SSP' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'Q' ) + WRITE(msgBuf,'(A)') ' Quad approximation to SSP' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'A' ) + WRITE(msgBuf,'(A)') ' Analytic SSP option' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + ! Attenuation options + SELECT CASE ( SSP%AttenUnit( 1:1 ) ) + CASE ( 'N' ) + WRITE(msgBuf,'(A)') ' Attenuation units: nepers/m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'F' ) + WRITE(msgBuf,'(A)') ' Attenuation units: dB/mkHz' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'M' ) + WRITE(msgBuf,'(A)') ' Attenuation units: dB/m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'W' ) + WRITE(msgBuf,'(A)') ' Attenuation units: dB/wavelength' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'Q' ) + WRITE(msgBuf,'(A)') ' Attenuation units: Q' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'L' ) + WRITE(msgBuf,'(A)') ' Attenuation units: Loss parameter' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + ! optional addition of volume attenuation using standard formulas + SELECT CASE ( SSP%AttenUnit( 2:2 ) ) + CASE ( 'T' ) + WRITE(msgBuf,'(A)') ' THORP volume attenuation added' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'F' ) + WRITE(msgBuf,'(A)') ' Francois-Garrison volume attenuation added' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE( PRTFile, & + "( ' T = ', G11.4, 'degrees S = ', G11.4, ' psu pH = ', G11.4, ' z_bar = ', G11.4, ' m' )" ) & + T, Salinity, pH, z_bar + CASE ( 'B' ) + WRITE(msgBuf,'(A)') ' Biological attenaution' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,I10)') ' Number of Bio Layers = ', NBioLayers + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + DO iBio = 1, NBioLayers + !READ( ENVFile, * ) bio( iBio )%Z1, bio( iBio )%Z2, bio( iBio )%f0, & + ! bio( iBio )%Q, bio( iBio )%a0 + WRITE(msgBuf, '(A,F10.4,A)') ' Top of layer = ', bio( iBio )%Z1, ' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf, '(A,F10.4,A)') ' Bottom of layer = ', bio( iBio )%Z2, ' m' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf, '(A,F10.4,A)') ' Resonance frequency = ', bio( iBio )%f0, & + ' Hz' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf, '(A,F10.4)') ' Q = ', bio( iBio )%Q + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf, '(A,F10.4)') ' a0 = ', bio( iBio )%a0 + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END DO + CASE ( ' ' ) + CASE DEFAULT + END SELECT + + SELECT CASE ( IHOP_TopOpt( 5:5 ) ) + CASE ( '~', '*' ) + WRITE(msgBuf,'(A)') ' Altimetry file selected' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( '-', '_', ' ' ) + CASE DEFAULT + END SELECT + + SELECT CASE ( IHOP_TopOpt( 6:6 ) ) + CASE ( 'I' ) + WRITE(msgBuf,'(A)') ' Development options enabled' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( ' ' ) + CASE DEFAULT + END SELECT +#endif /* IHOP_WRITE_OUT */ + + RETURN + END !SUBROUTINE WriteTopOpt + + !**********************************************************************! + + SUBROUTINE WriteRunType( RunType, myThid ) + USE ihop_mod, only: PRTFile + + ! Write the RunType variable to .prt file + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + CHARACTER*(7), INTENT( IN ) :: RunType + + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.LT.0) RETURN + +#ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + SELECT CASE ( RunType( 1:1 ) ) + CASE ( 'R' ) + WRITE(msgBuf,'(A)') 'Ray trace run' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'E' ) + WRITE(msgBuf,'(A)') 'Eigenray trace run' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'I' ) + WRITE(msgBuf,'(A)') 'Incoherent TL calculation' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'S' ) + WRITE(msgBuf,'(A)') 'Semi-coherent TL calculation' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'C' ) + WRITE(msgBuf,'(A)') 'Coherent TL calculation' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'A' ) + WRITE(msgBuf,'(A)') 'Arrivals calculation, ASCII file output' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'a' ) + WRITE(msgBuf,'(A)') 'Arrivals calculation, binary file output' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'e' ) + WRITE(msgBuf,'(A)') 'Eigenrays + Arrivals run, ASCII file output' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + SELECT CASE ( RunType( 2:2 ) ) + CASE ( 'C' ) + WRITE(msgBuf,'(A)') 'Cartesian beams' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'R' ) + WRITE(msgBuf,'(A)') 'Ray centered beams' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'S' ) + WRITE(msgBuf,'(A)') 'Simple gaussian beams' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'b' ) + WRITE(msgBuf,'(2A)') 'Geometric gaussian beams in ray-centered ', & + 'coordinates' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'B' ) + WRITE(msgBuf,'(A)') 'Geometric gaussian beams in Cartesian coordinates' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'g' ) + WRITE(msgBuf,'(A)') 'Geometric hat beams in ray-centered coordinates' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + SELECT CASE ( RunType( 4:4 ) ) + CASE ( 'R' ) + WRITE(msgBuf,'(A)') 'Point source (cylindrical coordinates)' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'X' ) + WRITE(msgBuf,'(A)') 'Line source (Cartesian coordinates)' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + SELECT CASE ( RunType( 5:5 ) ) + CASE ( 'R' ) + WRITE(msgBuf,'(2A)') 'Rectilinear receiver grid: Receivers at', & + ' ( Rr( ir ), Rz( ir ) ) )' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'I' ) + WRITE(msgBuf,'(A)') 'Irregular grid: Receivers at Rr( : ) x Rz( : )' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + SELECT CASE ( RunType( 6:6 ) ) + CASE ( '2' ) + WRITE(msgBuf,'(2A)') 'N x 2D calculation (neglects ', & + 'horizontal refraction)' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( '3' ) + WRITE(msgBuf,'(A)') '3D calculation' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + WRITE(msgBuf,'(2A)')'__________________________________________', & + '_________________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +#endif /* IHOP_WRITE_OUT */ + + RETURN + END !SUBROUTINE WriteRunType + + !**********************************************************************! + + SUBROUTINE WriteTopBot( HS, myThid ) + USE ihop_mod, only: PRTFile + USE ssp_mod, only: rhoR, alphaR, betaR, alphaI, betaI + + ! Handles top and bottom boundary conditions + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + TYPE ( HSInfo ), INTENT( IN ) :: HS + REAL (KIND=_RL90) :: Mz ! values related to grain size + +#ifdef IHOP_WRITE_OUT + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) THEN + ! Echo to PRTFile user's choice of boundary condition + + SELECT CASE ( HS%BC ) + CASE ( 'V' ) + WRITE(msgBuf,'(A)') ' Surface modeled as a VACUUM' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'R' ) + WRITE(msgBuf,'(A)') ' Perfectly RIGID' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'A' ) + WRITE(msgBuf,'(A)') ' ACOUSTO-ELASTIC half-space' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') & + ' z [m] alphaR [m/s] betaR rho [g/cm^3] alphaI betaI' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'( F10.2, 3X, 2F10.2, 3X, F6.2, 3X, 2F10.4 )' ) & + HS%Depth, alphaR, betaR, rhoR, alphaI, betaI + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'G' ) ! *** Grain size (formulas from UW-APL HF Handbook) + WRITE(msgBuf,'(A)') ' Grain size to define half-space' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'( F10.2, 3X, F10.2 )' ) HS%Depth, Mz + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,2F10.2,3X,A,F10.2,3X,A,F10.2)') & + 'Converted sound speed =', HS%cp, 'density = ', rhoR, & + 'loss parm = ', alphaI + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'F' ) + WRITE(msgBuf,'(A)') ' FILE used for reflection loss' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'W' ) + WRITE(msgBuf,'(A)') ' Writing an IRC file' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE ( 'P' ) + WRITE(msgBuf,'(A)') ' reading PRECALCULATED IRC' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + CASE DEFAULT + END SELECT + + END IF ! if in adjoint mode +#endif /* IHOP_WRITE_OUT */ + RETURN + END !SUBROUTINE WriteTopBot + + ! **********************************************************************! + + SUBROUTINE OpenOutputFiles( fName, myTime, myIter, myThid ) + USE ihop_mod, only: RAYFile, DELFile, ARRFile, SHDFile, Title, Beam + ! Write appropriate header information + + USE angle_mod, only: Angles + USE srPos_mod, only: Pos + + ! == Routine Arguments == + ! myTime :: Current time in simulation + ! myIter :: Current time-step number + ! myThid :: my Thread Id number + _RL, INTENT(IN) :: myTime + INTEGER, INTENT(IN) :: myIter, myThid + + ! == Local variables == + CHARACTER*(MAX_LEN_FNAM), INTENT(IN) :: fName + CHARACTER*(MAX_LEN_FNAM) :: fullName + INTEGER :: IL + REAL :: atten + CHARACTER (LEN=10) :: PlotType + + ! add time step to filename + IF (myIter.GE.0) THEN + IL=ILNBLNK( fName ) + WRITE(fullName, '(2A,I10.10)') fName(1:IL),'.',myIter + ELSE + fullName = fName + ENDIF + + SELECT CASE ( Beam%RunType( 1:1 ) ) + CASE ( 'R', 'E' ) ! Ray trace or Eigenrays +#ifdef IHOP_WRITE_OUT + OPEN ( FILE = TRIM( fullName ) // '.ray', UNIT = RAYFile, & + FORM = 'FORMATTED' ) + WRITE( RAYFile, * ) '''', Title( 1 : 50 ), '''' + WRITE( RAYFile, * ) IHOP_freq + WRITE( RAYFile, * ) Pos%NSx, Pos%NSy, Pos%NSz + WRITE( RAYFile, * ) Angles%Nalpha + WRITE( RAYFile, * ) Bdry%Top%HS%Depth + WRITE( RAYFile, * ) Bdry%Bot%HS%Depth + +#ifdef IHOP_THREED + WRITE( RAYFile, * ) Angles%Nalpha, Angles%Nbeta + WRITE( RAYFile, * ) '''xyz''' +#else /* IHOP_THREED */ + WRITE( RAYFile, * ) '''rz''' +#endif /* IHOP_THREED */ + FLUSH( RAYFile ) +#endif /* IHOP_WRITE_OUT */ + CASE ( 'e' ) ! eigenrays + arrival file in ascii format +#ifdef IHOP_WRITE_OUT + OPEN ( FILE = TRIM( fullName ) // '.arr', UNIT = ARRFile, & + FORM = 'FORMATTED' ) + +# ifdef IHOP_THREED + WRITE( ARRFile, * ) '''3D''' +# else /* IHOP_THREED */ + WRITE( ARRFile, * ) '''2D''' +# endif /* IHOP_THREED */ + + WRITE( ARRFile, * ) IHOP_freq + + ! write source locations +# ifdef IHOP_THREED + WRITE( ARRFile, * ) Pos%NSx, Pos%Sx( 1 : Pos%NSx ) + WRITE( ARRFile, * ) Pos%NSy, Pos%Sy( 1 : Pos%NSy ) + WRITE( ARRFile, * ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) +# else /* IHOP_THREED */ + WRITE( ARRFile, * ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) +# endif /* IHOP_THREED */ + + ! write receiver locations + WRITE( ARRFile, * ) Pos%NRz, Pos%Rz( 1 : Pos%NRz ) + WRITE( ARRFile, * ) Pos%NRr, Pos%Rr( 1 : Pos%NRr ) +# ifdef IHOP_THREED + WRITE( ARRFile, * ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta ) +# endif /* IHOP_THREED */ + + ! IEsco22: add erays to arrivals output + OPEN ( FILE = TRIM( fullName ) // '.ray', UNIT = RAYFile, & + FORM = 'FORMATTED' ) + WRITE( RAYFile, * ) '''', Title( 1 : 50 ), '''' + WRITE( RAYFile, * ) IHOP_freq + WRITE( RAYFile, * ) Pos%NSx, Pos%NSy, Pos%NSz + WRITE( RAYFile, * ) Angles%Nalpha + WRITE( RAYFile, * ) Bdry%Top%HS%Depth + WRITE( RAYFile, * ) Bdry%Bot%HS%Depth + +# ifdef IHOP_THREED + WRITE( RAYFile, * ) Angles%Nalpha, Angles%Nbeta + WRITE( RAYFile, * ) '''xyz''' +# else /* IHOP_THREED */ + WRITE( RAYFile, * ) '''rz''' +# endif /* IHOP_THREED */ + + IF (writeDelay) THEN + OPEN ( FILE = TRIM( fullName ) // '.delay', UNIT = DELFile, & + FORM = 'FORMATTED' ) + WRITE( DELFile, * ) '''', Title( 1 : 50 ), '''' + WRITE( DELFile, * ) IHOP_freq + WRITE( DELFile, * ) Pos%NSx, Pos%NSy, Pos%NSz + WRITE( DELFile, * ) Angles%Nalpha + WRITE( DELFile, * ) Bdry%Top%HS%Depth + WRITE( DELFile, * ) Bdry%Bot%HS%Depth + +#ifdef IHOP_THREED + WRITE( DELFile, * ) Angles%Nalpha, Angles%Nbeta + WRITE( DELFile, * ) '''xyz''' +# else /* IHOP_THREED */ + WRITE( DELFile, * ) '''rz''' +# endif /* IHOP_THREED */ + ENDIF + + FLUSH( RAYFile ) + IF (writeDelay) FLUSH( DELFile ) + FLUSH( ARRFile ) +#endif /* IHOP_WRITE_OUT */ + CASE ( 'A' ) ! arrival file in ascii format +#ifdef IHOP_WRITE_OUT + OPEN ( FILE = TRIM( fullName ) // '.arr', UNIT = ARRFile, & + FORM = 'FORMATTED' ) + +# ifdef IHOP_THREED + WRITE( ARRFile, * ) '''3D''' +# else /* IHOP_THREED */ + WRITE( ARRFile, * ) '''2D''' +# endif /* IHOP_THREED */ + + WRITE( ARRFile, * ) IHOP_freq + + ! write source locations +# ifdef IHOP_THREED + WRITE( ARRFile, * ) Pos%NSx, Pos%Sx( 1 : Pos%NSx ) + WRITE( ARRFile, * ) Pos%NSy, Pos%Sy( 1 : Pos%NSy ) +# endif /* IHOP_THREED */ + WRITE( ARRFile, * ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) + + ! write receiver locations + WRITE( ARRFile, * ) Pos%NRz, Pos%Rz( 1 : Pos%NRz ) + WRITE( ARRFile, * ) Pos%NRr, Pos%Rr( 1 : Pos%NRr ) +# ifdef IHOP_THREED + WRITE( ARRFile, * ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta ) +# endif /* IHOP_THREED */ + FLUSH( ARRFile ) +#endif /* IHOP_WRITE_OUT */ + CASE ( 'a' ) ! arrival file in binary format +#ifdef IHOP_WRITE_OUT + OPEN ( FILE = TRIM( fullName ) // '.arr', UNIT = ARRFile, & + FORM = 'UNFORMATTED' ) + +# ifdef IHOP_THREED + WRITE( ARRFile ) '''3D''' +# else /* IHOP_THREED */ + WRITE( ARRFile ) '''2D''' +# endif /* IHOP_THREED */ + + WRITE( ARRFile ) SNGL( IHOP_freq ) + + ! write source locations +# ifdef IHOP_THREED + WRITE( ARRFile ) Pos%NSx, Pos%Sx( 1 : Pos%NSx ) + WRITE( ARRFile ) Pos%NSy, Pos%Sy( 1 : Pos%NSy ) + WRITE( ARRFile ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) +# else /* IHOP_THREED */ + WRITE( ARRFile ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) +# endif /* IHOP_THREED */ + + ! write receiver locations + WRITE( ARRFile ) Pos%NRz, Pos%Rz( 1 : Pos%NRz ) + WRITE( ARRFile ) Pos%NRr, Pos%Rr( 1 : Pos%NRr ) +# ifdef IHOP_THREED + WRITE( ARRFile ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta ) +# endif /* IHOP_THREED */ + FLUSH( ARRFile ) +#endif /* IHOP_WRITE_OUT */ + CASE DEFAULT + atten = 0.0 + + ! following to set PlotType has alread been done in READIN if that was + ! used for input + SELECT CASE ( Beam%RunType( 5 : 5 ) ) + CASE ( 'R' ) + PlotType = 'rectilin ' + CASE ( 'I' ) + PlotType = 'irregular ' + CASE DEFAULT + PlotType = 'rectilin ' + END SELECT + + CALL WriteSHDHeader( TRIM( fullName ) // '.shd', Title, REAL( IHOP_freq ), & + atten, PlotType ) + END SELECT + + RETURN + END !SUBROUTINE OpenOutputFiles + + !**********************************************************************! + + SUBROUTINE WriteSHDHeader( FileName, Title, freq0, Atten, PlotType ) + + USE srPos_mod, only: Pos, Nfreq, freqVec + USE ihop_mod, only: SHDFile + + ! Write header to disk file + + REAL, INTENT( IN ) :: freq0, Atten ! Nominal frequency, stabilizing attenuation (for wavenumber integration only) + CHARACTER, INTENT( IN ) :: FileName*( * ) ! Name of the file (could be a shade file or a Green's function file) + CHARACTER, INTENT( IN ) :: Title*( * ) ! Arbitrary title + CHARACTER, INTENT( IN ) :: PlotType*( 10 ) ! + INTEGER :: LRecl + + ! receiver bearing angles + IF ( .NOT. ALLOCATED( Pos%theta ) ) THEN + ALLOCATE( Pos%theta( 1 ) ) + Pos%theta( 1 ) = 0 ! dummy bearing angle + Pos%Ntheta = 1 + END IF + + ! source x-coordinates + IF ( .NOT. ALLOCATED( Pos%Sx ) ) THEN + ALLOCATE( Pos%Sx( 1 ) ) + Pos%sx( 1 ) = 0 ! dummy x-coordinate + Pos%NSx = 1 + END IF + + ! source y-coordinates + IF ( .NOT. ALLOCATED( Pos%Sy ) ) THEN + ALLOCATE( Pos%Sy( 1 ) ) + Pos%sy( 1 ) = 0 ! dummy y-coordinate + Pos%NSy = 1 + END IF + + IF ( PlotType( 1 : 2 ) /= 'TL' ) THEN + ! MAX( 41, ... ) below because Title is already 40 words (or 80 bytes) + ! words/record (NRr doubled for complex pressure storage) + LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz, & + Pos%NRz, 2 * Pos%NRr ) + + OPEN ( FILE = FileName, UNIT = SHDFile, STATUS = 'REPLACE', & + ACCESS = 'DIRECT', RECL = 4 * LRecl, FORM = 'UNFORMATTED') + WRITE( SHDFile, REC = 1 ) LRecl, Title( 1 : 80 ) + WRITE( SHDFile, REC = 2 ) PlotType + WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& + Pos%NRz, Pos%NRr, freq0, atten + WRITE( SHDFile, REC = 4 ) freqVec( 1 : Nfreq ) + WRITE( SHDFile, REC = 5 ) Pos%theta( 1 : Pos%Ntheta ) + + WRITE( SHDFile, REC = 6 ) Pos%Sx( 1 : Pos%NSx ) + WRITE( SHDFile, REC = 7 ) Pos%Sy( 1 : Pos%NSy ) + WRITE( SHDFile, REC = 8 ) Pos%Sz( 1 : Pos%NSz ) + + WRITE( SHDFile, REC = 9 ) Pos%Rz( 1 : Pos%NRz ) + WRITE( SHDFile, REC = 10 ) Pos%Rr( 1 : Pos%NRr ) + + ELSE ! compressed format for TL from FIELD3D + ! words/record (NR doubled for complex pressure storage) + LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSz, Pos%NRz, 2 * Pos%NRr ) + + OPEN ( FILE = FileName, UNIT = SHDFile, STATUS = 'REPLACE', & + ACCESS = 'DIRECT', RECL = 4 * LRecl, FORM = 'UNFORMATTED') + WRITE( SHDFile, REC = 1 ) LRecl, Title( 1 : 80 ) + WRITE( SHDFile, REC = 2 ) PlotType + WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& + Pos%NRz, Pos%NRr, freq0, atten + WRITE( SHDFile, REC = 4 ) freqVec( 1 : Nfreq ) + WRITE( SHDFile, REC = 5 ) Pos%theta( 1 : Pos%Ntheta ) + + WRITE( SHDFile, REC = 6 ) Pos%Sx( 1 ), Pos%Sx( Pos%NSx ) + WRITE( SHDFile, REC = 7 ) Pos%Sy( 1 ), Pos%Sy( Pos%NSy ) + WRITE( SHDFile, REC = 8 ) Pos%Sz( 1 : Pos%NSz ) + + WRITE( SHDFile, REC = 9 ) Pos%Rz( 1 : Pos%NRz ) + WRITE( SHDFile, REC = 10 ) Pos%Rr( 1 : Pos%NRr ) + END IF + + RETURN + END !SUBROUTINE WriteSHDHeader + + !**********************************************************************! + + SUBROUTINE WriteSHDField( P, NRz, NRr, IRec ) + USE ihop_mod, only: SHDFile + + ! Write the field to disk + + INTEGER, INTENT( IN ) :: NRz, NRr ! # of receiver depths, ranges + COMPLEX, INTENT( IN ) :: P( NRz, NRr ) ! Pressure field + INTEGER, INTENT( INOUT ) :: iRec ! last record read + INTEGER :: iRz + + DO iRz = 1, NRz + iRec = iRec + 1 + WRITE( SHDFile, REC = iRec ) P( iRz, : ) + END DO + + RETURN + END !SUBROUTINE WriteSHDField + + !**********************************************************************! + + SUBROUTINE AllocatePos( Nx, x_out, x_in ) + + ! Allocate and populate Pos structure from data.ihop + + INTEGER, INTENT( IN ) :: Nx + REAL(KIND=_RL90), INTENT( IN ) :: x_in(:) + REAL(KIND=_RL90), ALLOCATABLE, INTENT( OUT ) :: x_out(:) + INTEGER :: i + + IF ( ALLOCATED(x_out) ) DEALLOCATE(x_out) + ALLOCATE( x_out(MAX(3, Nx)) ) + + ! set default values + x_out = 0.0 + x_out(3) = -999.9 + + DO i = 1, Nx + x_out(i) = x_in(i) + END DO + + RETURN + END !SUBROUTINE AllocatePos + + !**********************************************************************! + SUBROUTINE openPRTFile ( myTime, myIter, myThid ) + USE ihop_mod, only: PRTFile, Title + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! myTime :: Current time in simulation + ! myIter :: Current time-step number + ! msgBuf :: Used to build messages for printing. + _RL, INTENT(IN) :: myTime + INTEGER, INTENT(IN) :: myIter, myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + + ! == Local Arguments == + INTEGER :: iostat, ierr + ! For MPI writing: inspo from eeboot_minimal.F + CHARACTER*(MAX_LEN_FNAM) :: fNam + CHARACTER*(6) :: fmtStr + INTEGER :: mpiRC, IL +#ifdef ALLOW_CAL + INTEGER :: mydate(4) +#endif + + ! Open the print file: template from eeboot_minimal.F +#ifdef IHOP_WRITE_OUT + IF ( .NOT.usingMPI ) THEN + WRITE(myProcessStr, '(I10.10)') myIter + IL=ILNBLNK( myProcessStr ) + WRITE(fNam,'(4A)') TRIM(IHOP_fileroot),'.',myProcessStr(1:IL),'.prt' + IF ( IHOP_dumpfreq.GE.0 ) & + OPEN( PRTFile, FILE = fNam, STATUS = 'UNKNOWN', IOSTAT = iostat ) +#ifdef ALLOW_USE_MPI + ELSE ! using MPI + CALL MPI_COMM_RANK( MPI_COMM_MODEL, mpiMyId, mpiRC ) + myProcId = mpiMyId + IL = MAX(4,1+INT(LOG10(DFLOAT(nPx*nPy)))) + WRITE(fmtStr,'(2(A,I1),A)') '(I',IL,'.',IL,')' + WRITE(myProcessStr,fmtStr) myProcId + IL = ILNBLNK( myProcessStr ) + mpiPidIo = myProcId + pidIO = mpiPidIo + + IF( mpiPidIo.EQ.myProcId ) THEN +# ifdef SINGLE_DISK_IO + IF( myProcId.eq.0 ) THEN +# endif + IF (myIter.GE.0) THEN + WRITE(fNam,'(4A,I10.10,A)') & + TRIM(IHOP_fileroot),'.',myProcessStr(1:IL),'.',myIter,'.prt' + ELSE + WRITE(fNam,'(4A)') & + TRIM(IHOP_fileroot),'.',myProcessStr(1:IL),'.prt' + ENDIF + + IF ( IHOP_dumpfreq .GE. 0) & + OPEN(PRTFile, FILE=fNam, STATUS='UNKNOWN', IOSTAT=iostat ) + IF ( iostat /= 0 ) THEN + WRITE(*,*) 'ihop: IHOP_fileroot not recognized, ', & + TRIM(IHOP_fileroot) + WRITE(msgBuf,'(A)') 'IHOP_INIT: Unable to recognize file' + CALL PRINT_ERROR( msgBuf, myThid ) + STOP 'ABNORMAL END: S/R IHOP_INIT' + END IF +# ifdef SINGLE_DISK_IO + END IF +# endif + END IF +# endif /* ALLOW_USE_MPI */ + END IF +#endif /* IHOP_WRITE_OUT */ + + ! Only do I/O in the main thread + _BARRIER + _BEGIN_MASTER(myThid) + + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.LT.0) RETURN + +#ifdef IHOP_WRITE_OUT + WRITE(msgbuf,'(A)') 'iHOP Print File' + CALL PRINT_MESSAGE( msgBuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgbuf,'(A)') + CALL PRINT_MESSAGE( msgBuf, PRTFile, SQUEEZE_RIGHT, myThid ) +#endif /* IHOP_WRITE_OUT */ + + ! *** TITLE *** +#ifdef IHOP_THREED + WRITE(msgBuf,'(2A)') 'IHOP_INIT_DIAG openPRTFile: ', & + '3D not supported in ihop' + CALL PRINT_ERROR( msgBuf,myThid ) + STOP 'ABNORMAL END: S/R openPRTFile' + Title( 1 :11 ) = 'iHOP3D - ' + Title( 12:80 ) = IHOP_title +#else /* not IHOP_THREED */ + Title( 1 : 9 ) = 'iHOP - ' + Title( 10:80 ) = IHOP_title +#endif /* IHOP_THREED */ + +#ifdef IHOP_WRITE_OUT + WRITE(msgbuf,'(A)') Title ! , ACHAR(10) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)')'___________________________________________________', & + '________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgbuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE( msgBuf, '(A,I10,A,F20.2,A)') 'GCM iter ', myIter,' at time = ', & + myTime,' [sec]' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +# ifdef ALLOW_CAL + CALL CAL_GETDATE( myIter,myTime,mydate,myThid ) + WRITE (msgBuf,'(A,I8,I6,I3,I4)') 'GCM cal date ', mydate(1), mydate(2), & + mydate(3), mydate(4) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +# endif /* ALLOW_CAL */ + WRITE(msgbuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE( msgBuf, '(A,F11.4,A)' )'Frequency ', IHOP_freq, ' [Hz]' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)')'___________________________________________________', & + '________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) +#endif /* IHOP_WRITE_OUT */ + + ! Only do I/O in the main thread + _END_MASTER(myThid) + + END !SUBROUTINE openPRTFile + + + !**********************************************************************! + + SUBROUTINE resetMemory() + USE srpos_mod, only: Pos + USE bdry_mod, only: Top,Bot + USE angle_mod, only: Angles + USE arr_mod, only: Narr, Arr, U + USE ihop_mod, only: ray2D, MaxN, iStep + + ! From bdry_mod + IF (ALLOCATED(Top)) DEALLOCATE(Top) + IF (ALLOCATED(Bot)) DEALLOCATE(Bot) + ! From bellhop + IF (ALLOCATED(Pos%theta)) DEALLOCATE(Pos%theta) + IF (ALLOCATED(U)) DEALLOCATE(U) + IF (ALLOCATED(Arr)) DEALLOCATE(Arr) + IF (ALLOCATED(NArr)) DEALLOCATE(NArr) + ! From ssp_mod + IF (useSSPFile) THEN + ! don't reset values, they've been read in from a file -_- + ELSE + SSP%cmat = 1.0 + SSP%czmat = 1.0 +#ifdef IHOP_THREED + SSP%cmat3 = 1.0 + SSP%czmat3 = 1.0 +#endif /* IHOP_THREED */ + ENDIF + ! From ihop_mod + DO iStep = 1,MaxN + ray2D(iStep)%x = [zeroRL, zeroRL] + ray2D(iStep)%t = [zeroRL, zeroRL] + ray2D(iStep)%p = [zeroRL, zeroRL] + ray2D(iStep)%q = [zeroRL, zeroRL] + ray2D(iStep)%c = zeroRL + ray2D(iStep)%Amp = zeroRL + ray2D(iStep)%Phase = zeroRL + ray2D(iStep)%tau = (zeroRL, zeroRL) + END DO + + END !SUBROUTINE resetMemory + +END MODULE IHOP_INIT_DIAG diff --git a/src/ihop_init_fixed.F b/src/ihop_init_fixed.F index 7856a7d..3e47e5b 100644 --- a/src/ihop_init_fixed.F +++ b/src/ihop_init_fixed.F @@ -13,6 +13,7 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) C !USES: + use init_mod, only: ihop_init_fixed_env IMPLICIT NONE C ==================== Global Variables =========================== #include "EEPARAMS.h" @@ -134,11 +135,12 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) _END_MASTER( myThid ) C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| - DO k = 1,Nr - DO i=1,IHOP_npts_range + DO k = 1,IHOP_MAX_NC_SIZE !Nr + DO i=1,IHOP_MAX_NC_SIZE !IHOP_npts_range ihop_sumweights(i,k) = -1.0 END DO END DO + CALL ihop_init_fixed_env( myThid ) C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| #ifdef ALLOW_MNC diff --git a/src/initenvihop.F90 b/src/initenvihop.F90 deleted file mode 100644 index d2550f4..0000000 --- a/src/initenvihop.F90 +++ /dev/null @@ -1,1378 +0,0 @@ -#include "IHOP_OPTIONS.h" -!BOP -! !INTERFACE: -MODULE initenvihop -! -! Ivana Escobar -! - - ! mbp 12/2018, based on much older subroutine - - USE ihop_mod, only: PRTFile, RAYFile, DELFile, ARRFile, SHDFile, Title, Beam - USE ssp_mod, only: initSSP, SSP - USE bdry_mod, only: Bdry, HSInfo - USE atten_mod, only: CRCI - -! ! USES - implicit none -! == Global variables == -#include "SIZE.h" -#include "EEPARAMS.h" -#include "PARAMS.h" -#include "GRID.h" -#include "IHOP_SIZE.h" -#include "IHOP.h" -#ifdef ALLOW_CAL -#include "cal.h" -#endif /* ALLOW_CAL */ - - PRIVATE - -! == Public Interfaces == -!======================================================================= - public initEnv, OpenOutputFiles, resetMemory -!======================================================================= - -! INPUT/OUTPUT PARAMETERS: - -! == External Functions == - INTEGER ILNBLNK - EXTERNAL ILNBLNK - -CONTAINS - SUBROUTINE initEnv( myTime, myIter, myThid ) - - ! I/O routine for acoustic fixed inputS - - USE angle_mod, only: ReadRayElevationAngles - USE srpos_mod, only: Pos, ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec -#ifdef IHOP_THREED - USE angle_mod, only: ReadRayBearingAngles - USE srpos_mod, only: ReadRcvrBearings -#endif /* IHOP_THREED */ - - ! == Routine Arguments == - ! myTime :: Current time in simulation - ! myIter :: Current time-step number - ! myThid :: my Thread Id number - ! msgBuf :: Used to build messages for printing. - _RL, INTENT(IN) :: myTime - INTEGER, INTENT(IN) :: myIter, myThid - CHARACTER*(MAX_LEN_MBUF):: msgBuf - - ! == Local Variables == - REAL (KIND=_RL90), PARAMETER :: c0 = 1500.0 - REAL (KIND=_RL90) :: x(2), c, cimag, gradc(2), crz, czz, rho, Depth - CHARACTER (LEN= 2) :: AttenUnit - CHARACTER (LEN=10) :: PlotType - -!$TAF init initEnv1 = 'initenvihop_initenv' - - ! init local variables - AttenUnit = '' - PlotType = '' - - !RG - Bdry%Bot%HS = HSInfo(0.,0.,0.,0., 0.,0. , (0.,0.),(0.,0.), '', '' ) - Bdry%Top%HS = HSInfo(0.,0.,0.,0., 0.,0. , (0.,0.),(0.,0.), '', '' ) - - ! *** ihop info to PRTFile *** - CALL openPRTFile( myTime, myIter, myThid ) - - ! *** Top Boundary *** - Bdry%Top%HS%Opt = IHOP_topopt - Bdry%Top%HS%Depth = 0 !initiate to dummy value - - CALL ReadTopOpt( Bdry%Top%HS%BC, AttenUnit, myThid ) - CALL TopBot( AttenUnit, Bdry%Top%HS, myThid ) - - ! *** Bottom Boundary *** - Bdry%Bot%HS%Opt = IHOP_botopt - IF ( IHOP_depth.NE.0 ) THEN - Bdry%Bot%HS%Depth = IHOP_depth - ELSE - ! Extend by 5 wavelengths - Bdry%Bot%HS%Depth = rkSign*rF( Nr+1 ) + 5*c0/IHOP_freq - END IF - -#ifdef IHOP_WRITE_OUT - ! Only do I/O in the main thread - _BEGIN_MASTER(myThid) - - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,F10.2,A)' ) 'Depth = ',Bdry%Bot%HS%Depth,' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)') 'Top options: ', Bdry%Top%HS%Opt - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)') 'Bottom options: ', Bdry%Bot%HS%Opt - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - - SELECT CASE ( Bdry%Bot%HS%Opt( 2 : 2 ) ) - CASE ( '~', '*' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Bathymetry file selected' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE( ' ' ) - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP initEnv: ', & - 'Unknown bottom option letter in second position' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R initEnv' - END SELECT - ENDIF - ! Only do I/O in the main thread - _END_MASTER(myThid) -#endif /* IHOP_WRITE_OUT */ - - Bdry%Bot%HS%BC = Bdry%Bot%HS%Opt( 1:1 ) - CALL TopBot( AttenUnit, Bdry%Bot%HS, myThid ) - -! IESCO24: Write derived type with allocatable memory by type: Bdry from bdry_mod -! Scalar components -!$TAF store bdry%top%hs%depth,bdry%top%hs%bc = initEnv1 - -! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod -! Scalar components -! Fixed arrays -! Allocatable arrays -!$TAF store ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = initEnv1 - -! IESCO24: Write derived type with allocatable memory by type: Pos from srpos_mod -! Scalar components -! Allocatable arrays -!$TAF store pos%rr = initEnv1 -!$TAF store pos%theta,pos%wr,pos%ws = initEnv1 - - ! *** Ocean SSP *** - x = [ 0.0 _d 0, Bdry%Bot%HS%Depth ] ! tells SSP Depth to read to - CALL initSSP( x, myThid ) - - Bdry%Top%HS%Depth = SSP%z( 1 ) ! first SSP point is top depth - Depth = Bdry%Bot%HS%Depth - Bdry%Top%HS%Depth ! water column depth - - ! *** Source locations *** - CALL ReadSxSy( myThid ) ! Read source/receiver x-y coordinates - - Pos%NSz = IHOP_nsd - Pos%NRz = IHOP_nrd - - CALL AllocatePos( Pos%NSz, Pos%Sz, IHOP_sd ) - CALL AllocatePos( Pos%NRz, Pos%Rz, IHOP_rd ) - CALL ReadSzRz( Bdry%Top%HS%Depth, Bdry%Bot%HS%Depth, myThid ) - - ! *** Receiver locations *** - Pos%NRr = IHOP_nrr - CALL AllocatePos( Pos%NRr, Pos%Rr, IHOP_rr ) - CALL ReadRcvrRanges( myThid ) -#ifdef IHOP_THREED - CALL ReadRcvrBearings( myThid ) -#endif /* IHOP_THREED */ - - ! *** Broadband frequencies *** - CALL ReadfreqVec( Bdry%Top%HS%Opt( 6:6 ), myThid ) - - ! *** Run type *** - Beam%RunType = IHOP_runopt - CALL ReadRunType( Beam%RunType, PlotType, myThid ) - - CALL ReadRayElevationAngles( Depth, Bdry%Top%HS%Opt, Beam%RunType, myThid ) -#ifdef IHOP_THREED - CALL ReadRayBearingAngles( Bdry%Top%HS%Opt, Beam%RunType, myThid ) -#endif /* IHOP_THREED */ - - - ! *** Acoustic grid *** - - ! Limits for tracing beams -#ifdef IHOP_THREED - WRITE(msgBuf,'(2A)') 'INITENVIHOP initEnv: ', & - '3D not supported in ihop' - CALL PRINT_ERROR( msgBuf,myThid ) - STOP 'ABNORMAL END: S/R initEnv' - !READ( ENVFile, * ) Beam%deltas, Beam%Box%x, Beam%Box%y, Beam%Box%z - Beam%Box%x = 1000.0 * Beam%Box%x ! convert km to m - Beam%Box%y = 1000.0 * Beam%Box%y ! convert km to m - - ! Automatic step size selection - IF ( Beam%deltas == 0.0 ) Beam%deltas = & - ( Bdry%Bot%HS%Depth - Bdry%Top%HS%Depth ) / 10.0 -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')'______________________________________________', & - '_____________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,A,G11.4,A)') & - ' Step length,', ' deltas = ', Beam%deltas, ' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,G11.4,A)') & - ' Maximum ray x-range, Box%X = ', Beam%Box%X,' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,G11.4,A)') & - ' Maximum ray y-range, Box%Y = ', Beam%Box%Y,' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,G11.4,A)') & - ' Maximum ray z-range, Box%Z = ', Beam%Box%Z,' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ -#else /* not IHOP_THREED */ - ! Step size in meters [m] - Beam%deltas = IHOP_step - - IF ( Beam%deltas == 0.0 ) THEN ! Automatic step size option - Beam%deltas = ( Depth ) / 10. - END IF -#ifdef IHOP_WRITE_OUT - ! Only do I/O if in the main thread - _BEGIN_MASTER(myThid) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')'__________________________________________', & - '_________________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,G11.4,A)') & - ' Step length, deltas = ', Beam%deltas, ' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - - ENDIF - ! Only do I/O in the main thread - _END_MASTER(myThid) -#endif /* IHOP_WRITE_OUT */ - - ! Domain size - Beam%Box%Z = Bdry%Bot%HS%Depth ! in [m] - ! Extend beam box by a single step size forward - Beam%Box%R = IHOP_rr(nrd) + Beam%deltas/1000. ! in [km] - -#ifdef IHOP_WRITE_OUT - ! Only do I/O if in the main thread - _BEGIN_MASTER(myThid) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,G11.4,A)') & - ' Maximum ray range, Box%R = ', Beam%Box%R,' km' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,G11.4,A)') & - ' Maximum ray depth, Box%Z = ', Beam%Box%Z,' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - - ENDIF - ! Only do I/O in the main thread - _END_MASTER(myThid) -#endif /* IHOP_WRITE_OUT */ - - Beam%Box%R = Beam%Box%R*1000. ! convert km to m -#endif /* IHOP_THREED */ - - - ! *** Beam characteristics *** - Beam%Type( 4:4 ) = Beam%RunType( 7:7 ) ! selects beam shift option - -#ifdef IHOP_WRITE_OUT - ! Only do I/O if in the main thread - _BEGIN_MASTER(myThid) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - SELECT CASE ( Beam%Type( 4:4 ) ) - CASE ( 'S' ) - WRITE(msgBuf,'(A)') ' Beam shift in effect' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - CASE DEFAULT - WRITE(msgBuf,'(A)') ' No beam shift in effect' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END SELECT - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF - ! Only do I/O in the main thread - _END_MASTER(myThid) -#endif /* IHOP_WRITE_OUT */ - - ! don't worry about the beam type if this is a ray trace run - ! using 'e' requires Beam%Type to be set - IF ( Beam%RunType( 1:1 ) /= 'R' .OR. Beam%RunType( 1:1 ) /= 'E' ) THEN - - ! Beam%Type( 1 : 1 ) is - ! 'G' or '^' Geometric hat beams in Cartesian coordinates - ! 'g' Geometric hat beams in ray-centered coordinates - ! 'B' Geometric Gaussian beams in Cartesian coordinates - ! 'b' Geometric Gaussian beams in ray-centered coordinates - ! 'S' Simple Gaussian beams - ! Beam%Type( 2 : 2 ) controls the setting of the beam width - ! 'F' space Filling - ! 'M' minimum width - ! 'W' WKB beams - ! Beam%Type( 3 : 3 ) controls curvature changes on boundary reflections - ! 'D' Double - ! 'S' Single - ! 'Z' Zero - ! Beam%Type( 4 : 4 ) selects whether beam shifts are implemented on - ! boundary reflection - ! 'S' yes - ! 'N' no - - ! Curvature change can cause overflow in grazing case - ! Suppress by setting BeamType( 3 : 3 ) = 'Z' - - Beam%Type( 1:1 ) = Beam%RunType( 2:2 ) - - SELECT CASE ( Beam%Type( 1:1 ) ) - CASE ( 'G', 'g' , '^', 'B', 'b', 'S' ) - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - ! Only do I/O if in the main thread - _BEGIN_MASTER(myThid) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - - WRITE(msgBuf,'(2A)') 'INITENVIHOP initEnv: ', & - 'Unknown beam type (second letter of run type)' - CALL PRINT_ERROR( msgBuf,myThid ) - ENDIF ! No output in adjoint mode - ! Only do I/O in the main thread - _END_MASTER(myThid) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R initEnv' - END SELECT - - END IF - - RETURN - END !SUBROUTINE initEnv - - !**********************************************************************! - - SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) - USE atten_mod, only: T, Salinity, pH, z_bar, iBio, NBioLayers, bio - - ! == Routine Arguments == - ! myThid :: Thread number. Unused by IESCO - ! msgBuf :: Used to build messages for printing. - INTEGER, INTENT( IN ) :: myThid - CHARACTER*(MAX_LEN_MBUF):: msgBuf - - ! == Local Variables == - CHARACTER (LEN= 1), INTENT( OUT ) :: BC ! Boundary condition type - CHARACTER (LEN= 2), INTENT( INOUT ) :: AttenUnit - - SSP%Type = IHOP_TopOpt( 1:1 ) - BC = IHOP_TopOpt( 2:2 ) - AttenUnit = IHOP_TopOpt( 3:4 ) - SSP%AttenUnit = AttenUnit - - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.LT.0) RETURN - -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - - ! SSP approximation options - SELECT CASE ( SSP%Type ) - CASE ( 'N' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' N2-linear approximation to SSP' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'C' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' C-linear approximation to SSP' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'P' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' PCHIP approximation to SSP' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'S' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Spline approximation to SSP' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'Q' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Quad approximation to SSP' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'A' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Analytic SSP option' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & - 'Unknown option for SSP approximation' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadTopOpt' - END SELECT - - ! Attenuation options - - SELECT CASE ( AttenUnit( 1:1 ) ) - CASE ( 'N' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Attenuation units: nepers/m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'F' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Attenuation units: dB/mkHz' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'M' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Attenuation units: dB/m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'W' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Attenuation units: dB/wavelength' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'Q' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Attenuation units: Q' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'L' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Attenuation units: Loss parameter' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & - 'Unknown attenuation units' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadTopOpt' - END SELECT - - ! optional addition of volume attenuation using standard formulas - - SELECT CASE ( AttenUnit( 2:2 ) ) - CASE ( 'T' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' THORP volume attenuation added' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'F' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Francois-Garrison volume attenuation added' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE( PRTFile, & - "( ' T = ', G11.4, 'degrees S = ', G11.4, ' psu pH = ', G11.4, ' z_bar = ', G11.4, ' m' )" ) & - T, Salinity, pH, z_bar -#endif /* IHOP_WRITE_OUT */ - CASE ( 'B' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Biological attenaution' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,I10)') ' Number of Bio Layers = ', NBioLayers - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - - DO iBio = 1, NBioLayers - !READ( ENVFile, * ) bio( iBio )%Z1, bio( iBio )%Z2, bio( iBio )%f0, & - ! bio( iBio )%Q, bio( iBio )%a0 - WRITE(msgBuf, '(A,F10.4,A)') ' Top of layer = ', bio( iBio )%Z1, ' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf, '(A,F10.4,A)') ' Bottom of layer = ', bio( iBio )%Z2, ' m' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf, '(A,F10.4,A)') ' Resonance frequency = ', bio( iBio )%f0, & - ' Hz' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf, '(A,F10.4)') ' Q = ', bio( iBio )%Q - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf, '(A,F10.4)') ' a0 = ', bio( iBio )%a0 - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END DO -#endif /* IHOP_WRITE_OUT */ - CASE ( ' ' ) - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & - 'Unknown top option letter in fourth position' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadTopOpt' - END SELECT - - SELECT CASE ( IHOP_TopOpt( 5:5 ) ) - CASE ( '~', '*' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Altimetry file selected' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( '-', '_', ' ' ) - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & - 'Unknown top option letter in fifth position' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadTopOpt' - END SELECT - - SELECT CASE ( IHOP_TopOpt( 6:6 ) ) - CASE ( 'I' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Development options enabled' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( ' ' ) - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & - 'Unknown top option letter in sixth position' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadTopOpt' - END SELECT - - RETURN - END !SUBROUTINE ReadTopOpt - - !**********************************************************************! - - SUBROUTINE ReadRunType( RunType, PlotType, myThid ) - - ! Read the RunType variable and print to .prt file - - USE srPos_mod, only: Pos - - ! == Routine Arguments == - ! myThid :: Thread number. Unused by IESCO - ! msgBuf :: Used to build messages for printing. - INTEGER, INTENT( IN ) :: myThid - CHARACTER*(MAX_LEN_MBUF):: msgBuf - - ! == Local Variables == - CHARACTER (LEN= 7), INTENT( INOUT ) :: RunType - CHARACTER (LEN=10), INTENT( INOUT ) :: PlotType - - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.LT.0) RETURN - -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - - SELECT CASE ( RunType( 1:1 ) ) - CASE ( 'R' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Ray trace run' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'E' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Eigenray trace run' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'I' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Incoherent TL calculation' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'S' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Semi-coherent TL calculation' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'C' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Coherent TL calculation' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'A' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Arrivals calculation, ASCII file output' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'a' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Arrivals calculation, binary file output' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'e' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Eigenrays + Arrivals run, ASCII file output' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & - 'Unknown RunType selected' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadRunType' - END SELECT - - SELECT CASE ( RunType( 2:2 ) ) - CASE ( 'C' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Cartesian beams' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'R' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Ray centered beams' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'S' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Simple gaussian beams' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'b' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Geometric gaussian beams in ray-centered coordinates' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'B' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Geometric gaussian beams in Cartesian coordinates' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'g' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Geometric hat beams in ray-centered coordinates' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT - RunType( 2:2 ) = 'G' -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Geometric hat beams in Cartesian coordinates' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - END SELECT - - SELECT CASE ( RunType( 4:4 ) ) - CASE ( 'R' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Point source (cylindrical coordinates)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'X' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Line source (Cartesian coordinates)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT - RunType( 4:4 ) = 'R' -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Point source (cylindrical coordinates)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - END SELECT - - SELECT CASE ( RunType( 5:5 ) ) - CASE ( 'R' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'Rectilinear receiver grid: Receivers at', & - ' ( Rr( ir ), Rz( ir ) ) )' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - PlotType = 'rectilin ' - CASE ( 'I' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Irregular grid: Receivers at Rr( : ) x Rz( : )' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - IF ( Pos%NRz /= Pos%NRr ) THEN -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & - 'Irregular grid option selected with NRz not equal to Nr' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ReadRunType' - END IF - PlotType = 'irregular ' - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'Rectilinear receiver grid: Receivers at', & - ' Rr( : ) x Rz( : )' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - RunType( 5:5 ) = 'R' - PlotType = 'rectilin ' - END SELECT - - SELECT CASE ( RunType( 6:6 ) ) - CASE ( '2' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'N x 2D calculation (neglects horizontal refraction)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( '3' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') '3D calculation' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT - RunType( 6:6 ) = '2' - END SELECT - - RETURN - END !SUBROUTINE ReadRunType - - !**********************************************************************! - - SUBROUTINE TopBot( AttenUnit, HS, myThid ) - USE ssp_mod, only: rhoR, alphaR, betaR, alphaI, betaI - - ! Handles top and bottom boundary conditions - - ! == Routine Arguments == - ! myThid :: Thread number. Unused by IESCO - ! msgBuf :: Used to build messages for printing. - INTEGER, INTENT( IN ) :: myThid - CHARACTER*(MAX_LEN_MBUF):: msgBuf - - ! == Local Variables == - CHARACTER (LEN=2), INTENT( IN ) :: AttenUnit - TYPE ( HSInfo ), INTENT( INOUT ) :: HS - REAL (KIND=_RL90) :: Mz, vr, alpha2_f ! values related to grain size - REAL (KIND=_RL90) :: ztemp, bPower, fT - - ! ****** Read in BC parameters depending on particular choice ****** - HS%cp = 0.0 - HS%cs = 0.0 - HS%rho = 0.0 - - ! RG recommends resetting to the default values from ssp_mod.F90 - bPower = 1.0 - fT = 1D20 - rhoR = 1.0 - - - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - ! Echo to PRTFile user's choice of boundary condition - - SELECT CASE ( HS%BC ) - CASE ( 'V' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Surface modeled as a VACUUM' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'R' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Perfectly RIGID' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'A' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' ACOUSTO-ELASTIC half-space' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'G' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Grain size to define half-space' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'F' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' FILE used for reflection loss' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'W' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' Writing an IRC file' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'P' ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') ' reading PRECALCULATED IRC' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP TopBot: ', & - 'Unknown boundary condition type' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R TopBot' - END SELECT - ENDIF ! no output on adjoint runs - - SELECT CASE ( HS%BC ) - CASE ( 'V','R','F','W','P') - CASE ( 'A' ) ! *** Half-space properties *** - ! IEsco23: MISSING IF BOTTOM BC CHECK - zTemp = HS%Depth - alphaR = IHOP_bcsound - betaR = IHOP_bcsoundshear - rhoR = IHOP_brho - alphaI = IHOP_bcsoundI - betaI = IHOP_bcsoundshearI -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') & - ' z (m) alphaR (m/s) betaR rho (g/cm^3) alphaI betaI' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'( F10.2, 3X, 2F10.2, 3X, F6.2, 3X, 2F10.4 )' ) & - zTemp, alphaR, betaR, rhoR, alphaI, betaI - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ - ! dummy parameters for a layer with a general power law for attenuation - ! these are not in play because the AttenUnit for this is not allowed yet - fT = 1000.0 - - HS%cp = CRCI( zTemp, alphaR, alphaI, AttenUnit, bPower, fT, myThid ) - HS%cs = CRCI( zTemp, betaR, betaI, AttenUnit, bPower, fT, myThid ) - - HS%rho = rhoR - CASE ( 'G' ) ! *** Grain size (formulas from UW-APL HF Handbook) - ! These formulas are from the UW-APL Handbook - ! The code is taken from older Matlab and is unnecesarily verbose - ! vr is the sound speed ratio - ! rhoR is the density ratio - !READ( ENVFile, * ) zTemp, Mz -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'( F10.2, 3X, F10.2 )' ) zTemp, Mz - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - - IF ( Mz >= -1 .AND. Mz < 1 ) THEN - vr = 0.002709 * Mz**2 - 0.056452 * Mz + 1.2778 - rhoR = 0.007797 * Mz**2 - 0.17057 * Mz + 2.3139 - ELSE IF ( Mz >= 1 .AND. Mz < 5.3 ) THEN - vr = -0.0014881 * Mz**3 + 0.0213937 * Mz**2 - 0.1382798 * Mz & - + 1.3425 - rhoR = -0.0165406 * Mz**3 + 0.2290201 * Mz**2 - 1.1069031 * Mz & - + 3.0455 - ELSE - vr = -0.0024324 * Mz + 1.0019 - rhoR = -0.0012973 * Mz + 1.1565 - END IF - - IF ( Mz >= -1 .AND. Mz < 0 ) THEN - alpha2_f = 0.4556 - ELSE IF ( Mz >= 0 .AND. Mz < 2.6 ) THEN - alpha2_f = 0.4556 + 0.0245 * Mz - ELSE IF( Mz >= 2.6 .AND. Mz < 4.5 ) THEN - alpha2_f = 0.1978 + 0.1245 * Mz - ELSE IF( Mz >= 4.5 .AND. Mz < 6.0 ) THEN - alpha2_f = 8.0399 - 2.5228 * Mz + 0.20098 * Mz ** 2 - ELSE IF( Mz >= 6.0 .AND. Mz < 9.5 ) THEN - alpha2_f = 0.9431 - 0.2041 * Mz + 0.0117 * Mz ** 2 - ELSE - alpha2_f = 0.0601 - END IF - - ! AttenUnit = 'L' ! loss parameter -!!! following uses a reference sound speed of 1500 ??? -!!! should be sound speed in the water, just above the sediment - ! the term vr / 1000 converts vr to units of m per ms - alphaR = vr * 1500.0 - ! loss parameter Sect. IV., Eq. (4) of handbook - alphaI = alpha2_f * ( vr / 1000 ) * 1500.0 * log( 10.0 ) / ( 40.0*PI ) - - HS%cp = CRCI( zTemp, alphaR, alphaI, 'L ', bPower, fT, myThid ) - HS%cs = 0.0 - HS%rho = rhoR -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A,2F10.2,3X,A,F10.2,3X,A,F10.2)') & - 'Converted sound speed =', HS%cp, 'density = ', rhoR, & - 'loss parm = ', alphaI - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP TopBot: ', & - 'Unknown boundary condition type' - CALL PRINT_ERROR( msgBuf,myThid ) -#endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R TopBot' - END SELECT - - RETURN - END !SUBROUTINE TopBot - - ! **********************************************************************! - - SUBROUTINE OpenOutputFiles( fName, myTime, myIter, myThid ) - ! Write appropriate header information - - USE angle_mod, only: Angles - USE srPos_mod, only: Pos - - ! == Routine Arguments == - ! myTime :: Current time in simulation - ! myIter :: Current time-step number - ! myThid :: my Thread Id number - _RL, INTENT(IN) :: myTime - INTEGER, INTENT(IN) :: myIter, myThid - - ! == Local variables == - CHARACTER*(MAX_LEN_FNAM), INTENT(IN) :: fName - CHARACTER*(MAX_LEN_FNAM) :: fullName - INTEGER :: IL - REAL :: atten - CHARACTER (LEN=10) :: PlotType - - ! add time step to filename - IF (myIter.GE.0) THEN - IL=ILNBLNK( fName ) - WRITE(fullName, '(2A,I10.10)') fName(1:IL),'.',myIter - ELSE - fullName = fName - ENDIF - - SELECT CASE ( Beam%RunType( 1:1 ) ) - CASE ( 'R', 'E' ) ! Ray trace or Eigenrays -#ifdef IHOP_WRITE_OUT - OPEN ( FILE = TRIM( fullName ) // '.ray', UNIT = RAYFile, & - FORM = 'FORMATTED' ) - WRITE( RAYFile, * ) '''', Title( 1 : 50 ), '''' - WRITE( RAYFile, * ) IHOP_freq - WRITE( RAYFile, * ) Pos%NSx, Pos%NSy, Pos%NSz - WRITE( RAYFile, * ) Angles%Nalpha - WRITE( RAYFile, * ) Bdry%Top%HS%Depth - WRITE( RAYFile, * ) Bdry%Bot%HS%Depth - -#ifdef IHOP_THREED - WRITE( RAYFile, * ) Angles%Nalpha, Angles%Nbeta - WRITE( RAYFile, * ) '''xyz''' -#else /* IHOP_THREED */ - WRITE( RAYFile, * ) '''rz''' -#endif /* IHOP_THREED */ - FLUSH( RAYFile ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'e' ) ! eigenrays + arrival file in ascii format -#ifdef IHOP_WRITE_OUT - OPEN ( FILE = TRIM( fullName ) // '.arr', UNIT = ARRFile, & - FORM = 'FORMATTED' ) - -# ifdef IHOP_THREED - WRITE( ARRFile, * ) '''3D''' -# else /* IHOP_THREED */ - WRITE( ARRFile, * ) '''2D''' -# endif /* IHOP_THREED */ - - WRITE( ARRFile, * ) IHOP_freq - - ! write source locations -# ifdef IHOP_THREED - WRITE( ARRFile, * ) Pos%NSx, Pos%Sx( 1 : Pos%NSx ) - WRITE( ARRFile, * ) Pos%NSy, Pos%Sy( 1 : Pos%NSy ) - WRITE( ARRFile, * ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) -# else /* IHOP_THREED */ - WRITE( ARRFile, * ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) -# endif /* IHOP_THREED */ - - ! write receiver locations - WRITE( ARRFile, * ) Pos%NRz, Pos%Rz( 1 : Pos%NRz ) - WRITE( ARRFile, * ) Pos%NRr, Pos%Rr( 1 : Pos%NRr ) -# ifdef IHOP_THREED - WRITE( ARRFile, * ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta ) -# endif /* IHOP_THREED */ - - ! IEsco22: add erays to arrivals output - OPEN ( FILE = TRIM( fullName ) // '.ray', UNIT = RAYFile, & - FORM = 'FORMATTED' ) - WRITE( RAYFile, * ) '''', Title( 1 : 50 ), '''' - WRITE( RAYFile, * ) IHOP_freq - WRITE( RAYFile, * ) Pos%NSx, Pos%NSy, Pos%NSz - WRITE( RAYFile, * ) Angles%Nalpha - WRITE( RAYFile, * ) Bdry%Top%HS%Depth - WRITE( RAYFile, * ) Bdry%Bot%HS%Depth - -# ifdef IHOP_THREED - WRITE( RAYFile, * ) Angles%Nalpha, Angles%Nbeta - WRITE( RAYFile, * ) '''xyz''' -# else /* IHOP_THREED */ - WRITE( RAYFile, * ) '''rz''' -# endif /* IHOP_THREED */ - - IF (writeDelay) THEN - OPEN ( FILE = TRIM( fullName ) // '.delay', UNIT = DELFile, & - FORM = 'FORMATTED' ) - WRITE( DELFile, * ) '''', Title( 1 : 50 ), '''' - WRITE( DELFile, * ) IHOP_freq - WRITE( DELFile, * ) Pos%NSx, Pos%NSy, Pos%NSz - WRITE( DELFile, * ) Angles%Nalpha - WRITE( DELFile, * ) Bdry%Top%HS%Depth - WRITE( DELFile, * ) Bdry%Bot%HS%Depth - -#ifdef IHOP_THREED - WRITE( DELFile, * ) Angles%Nalpha, Angles%Nbeta - WRITE( DELFile, * ) '''xyz''' -# else /* IHOP_THREED */ - WRITE( DELFile, * ) '''rz''' -# endif /* IHOP_THREED */ - ENDIF - - FLUSH( RAYFile ) - IF (writeDelay) FLUSH( DELFile ) - FLUSH( ARRFile ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'A' ) ! arrival file in ascii format -#ifdef IHOP_WRITE_OUT - OPEN ( FILE = TRIM( fullName ) // '.arr', UNIT = ARRFile, & - FORM = 'FORMATTED' ) - -# ifdef IHOP_THREED - WRITE( ARRFile, * ) '''3D''' -# else /* IHOP_THREED */ - WRITE( ARRFile, * ) '''2D''' -# endif /* IHOP_THREED */ - - WRITE( ARRFile, * ) IHOP_freq - - ! write source locations -# ifdef IHOP_THREED - WRITE( ARRFile, * ) Pos%NSx, Pos%Sx( 1 : Pos%NSx ) - WRITE( ARRFile, * ) Pos%NSy, Pos%Sy( 1 : Pos%NSy ) -# endif /* IHOP_THREED */ - WRITE( ARRFile, * ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) - - ! write receiver locations - WRITE( ARRFile, * ) Pos%NRz, Pos%Rz( 1 : Pos%NRz ) - WRITE( ARRFile, * ) Pos%NRr, Pos%Rr( 1 : Pos%NRr ) -# ifdef IHOP_THREED - WRITE( ARRFile, * ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta ) -# endif /* IHOP_THREED */ - FLUSH( ARRFile ) -#endif /* IHOP_WRITE_OUT */ - CASE ( 'a' ) ! arrival file in binary format -#ifdef IHOP_WRITE_OUT - OPEN ( FILE = TRIM( fullName ) // '.arr', UNIT = ARRFile, & - FORM = 'UNFORMATTED' ) - -# ifdef IHOP_THREED - WRITE( ARRFile ) '''3D''' -# else /* IHOP_THREED */ - WRITE( ARRFile ) '''2D''' -# endif /* IHOP_THREED */ - - WRITE( ARRFile ) SNGL( IHOP_freq ) - - ! write source locations -# ifdef IHOP_THREED - WRITE( ARRFile ) Pos%NSx, Pos%Sx( 1 : Pos%NSx ) - WRITE( ARRFile ) Pos%NSy, Pos%Sy( 1 : Pos%NSy ) - WRITE( ARRFile ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) -# else /* IHOP_THREED */ - WRITE( ARRFile ) Pos%NSz, Pos%Sz( 1 : Pos%NSz ) -# endif /* IHOP_THREED */ - - ! write receiver locations - WRITE( ARRFile ) Pos%NRz, Pos%Rz( 1 : Pos%NRz ) - WRITE( ARRFile ) Pos%NRr, Pos%Rr( 1 : Pos%NRr ) -# ifdef IHOP_THREED - WRITE( ARRFile ) Pos%Ntheta, Pos%theta( 1 : Pos%Ntheta ) -# endif /* IHOP_THREED */ - FLUSH( ARRFile ) -#endif /* IHOP_WRITE_OUT */ - CASE DEFAULT - atten = 0.0 - - ! following to set PlotType has alread been done in READIN if that was - ! used for input - SELECT CASE ( Beam%RunType( 5 : 5 ) ) - CASE ( 'R' ) - PlotType = 'rectilin ' - CASE ( 'I' ) - PlotType = 'irregular ' - CASE DEFAULT - PlotType = 'rectilin ' - END SELECT - - CALL WriteSHDHeader( TRIM( fullName ) // '.shd', Title, REAL( IHOP_freq ), & - atten, PlotType ) - END SELECT - - RETURN - END !SUBROUTINE OpenOutputFiles - - !**********************************************************************! - - SUBROUTINE WriteSHDHeader( FileName, Title, freq0, Atten, PlotType ) - - USE srPos_mod, only: Pos, Nfreq, freqVec - - ! Write header to disk file - - REAL, INTENT( IN ) :: freq0, Atten ! Nominal frequency, stabilizing attenuation (for wavenumber integration only) - CHARACTER, INTENT( IN ) :: FileName*( * ) ! Name of the file (could be a shade file or a Green's function file) - CHARACTER, INTENT( IN ) :: Title*( * ) ! Arbitrary title - CHARACTER, INTENT( IN ) :: PlotType*( 10 ) ! - INTEGER :: LRecl - - ! receiver bearing angles - IF ( .NOT. ALLOCATED( Pos%theta ) ) THEN - ALLOCATE( Pos%theta( 1 ) ) - Pos%theta( 1 ) = 0 ! dummy bearing angle - Pos%Ntheta = 1 - END IF - - ! source x-coordinates - IF ( .NOT. ALLOCATED( Pos%Sx ) ) THEN - ALLOCATE( Pos%Sx( 1 ) ) - Pos%sx( 1 ) = 0 ! dummy x-coordinate - Pos%NSx = 1 - END IF - - ! source y-coordinates - IF ( .NOT. ALLOCATED( Pos%Sy ) ) THEN - ALLOCATE( Pos%Sy( 1 ) ) - Pos%sy( 1 ) = 0 ! dummy y-coordinate - Pos%NSy = 1 - END IF - - IF ( PlotType( 1 : 2 ) /= 'TL' ) THEN - ! MAX( 41, ... ) below because Title is already 40 words (or 80 bytes) - ! words/record (NRr doubled for complex pressure storage) - LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz, & - Pos%NRz, 2 * Pos%NRr ) - - OPEN ( FILE = FileName, UNIT = SHDFile, STATUS = 'REPLACE', & - ACCESS = 'DIRECT', RECL = 4 * LRecl, FORM = 'UNFORMATTED') - WRITE( SHDFile, REC = 1 ) LRecl, Title( 1 : 80 ) - WRITE( SHDFile, REC = 2 ) PlotType - WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& - Pos%NRz, Pos%NRr, freq0, atten - WRITE( SHDFile, REC = 4 ) freqVec( 1 : Nfreq ) - WRITE( SHDFile, REC = 5 ) Pos%theta( 1 : Pos%Ntheta ) - - WRITE( SHDFile, REC = 6 ) Pos%Sx( 1 : Pos%NSx ) - WRITE( SHDFile, REC = 7 ) Pos%Sy( 1 : Pos%NSy ) - WRITE( SHDFile, REC = 8 ) Pos%Sz( 1 : Pos%NSz ) - - WRITE( SHDFile, REC = 9 ) Pos%Rz( 1 : Pos%NRz ) - WRITE( SHDFile, REC = 10 ) Pos%Rr( 1 : Pos%NRr ) - - ELSE ! compressed format for TL from FIELD3D - ! words/record (NR doubled for complex pressure storage) - LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSz, Pos%NRz, 2 * Pos%NRr ) - - OPEN ( FILE = FileName, UNIT = SHDFile, STATUS = 'REPLACE', & - ACCESS = 'DIRECT', RECL = 4 * LRecl, FORM = 'UNFORMATTED') - WRITE( SHDFile, REC = 1 ) LRecl, Title( 1 : 80 ) - WRITE( SHDFile, REC = 2 ) PlotType - WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& - Pos%NRz, Pos%NRr, freq0, atten - WRITE( SHDFile, REC = 4 ) freqVec( 1 : Nfreq ) - WRITE( SHDFile, REC = 5 ) Pos%theta( 1 : Pos%Ntheta ) - - WRITE( SHDFile, REC = 6 ) Pos%Sx( 1 ), Pos%Sx( Pos%NSx ) - WRITE( SHDFile, REC = 7 ) Pos%Sy( 1 ), Pos%Sy( Pos%NSy ) - WRITE( SHDFile, REC = 8 ) Pos%Sz( 1 : Pos%NSz ) - - WRITE( SHDFile, REC = 9 ) Pos%Rz( 1 : Pos%NRz ) - WRITE( SHDFile, REC = 10 ) Pos%Rr( 1 : Pos%NRr ) - END IF - - RETURN - END !SUBROUTINE WriteSHDHeader - - !**********************************************************************! - - SUBROUTINE WriteSHDField( P, NRz, NRr, IRec ) - - ! Write the field to disk - - INTEGER, INTENT( IN ) :: NRz, NRr ! # of receiver depths, ranges - COMPLEX, INTENT( IN ) :: P( NRz, NRr ) ! Pressure field - INTEGER, INTENT( INOUT ) :: iRec ! last record read - INTEGER :: iRz - - DO iRz = 1, NRz - iRec = iRec + 1 - WRITE( SHDFile, REC = iRec ) P( iRz, : ) - END DO - - RETURN - END !SUBROUTINE WriteSHDField - - !**********************************************************************! - - SUBROUTINE AllocatePos( Nx, x_out, x_in ) - - ! Allocate and populate Pos structure from data.ihop - - INTEGER, INTENT( IN ) :: Nx - REAL(KIND=_RL90), INTENT( IN ) :: x_in(:) - REAL(KIND=_RL90), ALLOCATABLE, INTENT( OUT ) :: x_out(:) - INTEGER :: i - - IF ( ALLOCATED(x_out) ) DEALLOCATE(x_out) - ALLOCATE( x_out(MAX(3, Nx)) ) - - ! set default values - x_out = 0.0 - x_out(3) = -999.9 - - DO i = 1, Nx - x_out(i) = x_in(i) - END DO - - RETURN - END !SUBROUTINE AllocatePos - - !**********************************************************************! - SUBROUTINE openPRTFile ( myTime, myIter, myThid ) - - ! == Routine Arguments == - ! myThid :: Thread number. Unused by IESCO - ! myTime :: Current time in simulation - ! myIter :: Current time-step number - ! msgBuf :: Used to build messages for printing. - _RL, INTENT(IN) :: myTime - INTEGER, INTENT(IN) :: myIter, myThid - CHARACTER*(MAX_LEN_MBUF):: msgBuf - - ! == Local Arguments == -#ifdef ALLOW_CAL - INTEGER :: mydate(4) -#endif - - ! Only do I/O in the main thread - _BARRIER - _BEGIN_MASTER(myThid) - - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.LT.0) RETURN - -#ifdef IHOP_WRITE_OUT - WRITE(msgbuf,'(A)') 'iHOP Print File' - CALL PRINT_MESSAGE( msgBuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgbuf,'(A)') - CALL PRINT_MESSAGE( msgBuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - - ! *** TITLE *** -#ifdef IHOP_THREED - WRITE(msgBuf,'(2A)') 'INITENVIHOP openPRTFile: ', & - '3D not supported in ihop' - CALL PRINT_ERROR( msgBuf,myThid ) - STOP 'ABNORMAL END: S/R initEnv' - Title( 1 :11 ) = 'iHOP3D - ' - Title( 12:80 ) = IHOP_title -#else /* not IHOP_THREED */ - Title( 1 : 9 ) = 'iHOP - ' - Title( 10:80 ) = IHOP_title -#endif /* IHOP_THREED */ - -#ifdef IHOP_WRITE_OUT - WRITE(msgbuf,'(A)') Title ! , ACHAR(10) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')'___________________________________________________', & - '________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgbuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE( msgBuf, '(A,I10,A,F20.2,A)') 'GCM iter ', myIter,' at time = ', & - myTime,' [sec]' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -# ifdef ALLOW_CAL - CALL CAL_GETDATE( myIter,myTime,mydate,myThid ) - WRITE (msgBuf,'(A,I8,I6,I3,I4)') 'GCM cal date ', mydate(1), mydate(2), & - mydate(3), mydate(4) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -# endif /* ALLOW_CAL */ - WRITE(msgbuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE( msgBuf, '(A,F11.4,A)' )'Frequency ', IHOP_freq, ' [Hz]' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')'___________________________________________________', & - '________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ - - ! Only do I/O in the main thread - _END_MASTER(myThid) - - END !SUBROUTINE openPRTFile - - - !**********************************************************************! - - SUBROUTINE resetMemory() - USE srpos_mod, only: Pos - USE bdry_mod, only: Top,Bot - USE angle_mod, only: Angles - USE arr_mod, only: Narr, Arr - USE ihop_mod, only: ray2D, MaxN, iStep - - ! From angle_mod - IF (ALLOCATED(Angles%alpha))DEALLOCATE(Angles%alpha) -#ifdef IHOP_THREED - IF (ALLOCATED(Angles%beta)) DEALLOCATE(Angles%beta) -#endif /* IHOP_THREED */ - ! From bdry_mod - IF (ALLOCATED(Top)) DEALLOCATE(Top) - IF (ALLOCATED(Bot)) DEALLOCATE(Bot) - ! From bellhop - IF (ALLOCATED(Pos%theta)) DEALLOCATE(Pos%theta) - IF (ALLOCATED(Arr)) DEALLOCATE(Arr) - IF (ALLOCATED(NArr)) DEALLOCATE(NArr) - ! from initenvihop - IF (ALLOCATED(Pos%Sx)) DEALLOCATE(Pos%Sx) - IF (ALLOCATED(Pos%Sy)) DEALLOCATE(Pos%Sy) - IF (ALLOCATED(Pos%Sz)) DEALLOCATE(Pos%Sz) - ! From srpos_mod - IF (ALLOCATED(Pos%ws)) DEALLOCATE(Pos%ws) - IF (ALLOCATED(Pos%isz)) DEALLOCATE(Pos%isz) - IF (ALLOCATED(Pos%wr)) DEALLOCATE(Pos%wr) - IF (ALLOCATED(Pos%irz)) DEALLOCATE(Pos%irz) - IF (ALLOCATED(Pos%rr)) DEALLOCATE(Pos%rr) - IF (ALLOCATED(Pos%rz)) DEALLOCATE(Pos%rz) - ! From ssp_mod - IF (ALLOCATED(SSP%cMat)) DEALLOCATE(SSP%cMat) - IF (ALLOCATED(SSP%czMat)) DEALLOCATE(SSP%czMat) -#ifdef IHOP_THREED - IF (ALLOCATED(SSP%cMat3)) DEALLOCATE(SSP%cMat3) - IF (ALLOCATED(SSP%czMat3)) DEALLOCATE(SSP%czMat3) -#endif /* IHOP_THREED */ - IF (ALLOCATED(SSP%Seg%r)) DEALLOCATE(SSP%Seg%r) - ! From ihop_mod - DO iStep = 1,MaxN - ray2D(iStep)%x = [zeroRL, zeroRL] - ray2D(iStep)%t = [zeroRL, zeroRL] - ray2D(iStep)%p = [zeroRL, zeroRL] - ray2D(iStep)%q = [zeroRL, zeroRL] - ray2D(iStep)%c = zeroRL - ray2D(iStep)%Amp = zeroRL - ray2D(iStep)%Phase = zeroRL - ray2D(iStep)%tau = (zeroRL, zeroRL) - END DO - - END !SUBROUTINE resetMemory - -END MODULE initenvihop diff --git a/src/srpos_mod.F90 b/src/srpos_mod.F90 index e475111..789b7d6 100644 --- a/src/srpos_mod.F90 +++ b/src/srpos_mod.F90 @@ -27,10 +27,11 @@ MODULE srpos_mod ! public interfaces !======================================================================= - public Pos, Nfreq, freqVec, ReadSxSy, ReadSzRz, & - ReadRcvrRanges, ReadFreqVec + public Pos, Nfreq, freqVec, & + ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec, & + WriteSxSy, WriteSzRz, WriteRcvrRanges, WriteFreqVec #ifdef IHOP_THREED - public ReadRcvrBearings + public ReadRcvrBearings, WriteRcvrBearings #endif /* IHOP_THREED */ !======================================================================= @@ -75,17 +76,6 @@ SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) IF (IHOP_dumpfreq.GE.0) THEN ! Broadband run? IF ( BroadbandOption == 'B' ) THEN -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)')'___________________________________________',& - '________________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,I10)') 'Number of frequencies =', Nfreq - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ IF ( Nfreq <= 0 ) THEN #ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(2A)') 'SRPOSITIONS ReadfreqVec: ', & @@ -112,27 +102,10 @@ SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) freqVec = 0.0 IF ( BroadbandOption == 'B' ) THEN -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Frequencies (Hz)' - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ freqVec(3) = -999.9 !READ( ENVFile, * ) freqVec( 1 : Nfreq ) CALL SubTab( freqVec, Nfreq ) -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE( msgBuf, '(5G14.6)' ) ( freqVec( ifreq ), ifreq = 1, & - MIN( Nfreq, Number_to_Echo ) ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - IF ( Nfreq > Number_to_Echo ) & - WRITE( msgBuf,'(G14.6)' ) ' ... ', freqVec( Nfreq ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ ELSE freqVec(1) = IHOP_freq END IF @@ -225,41 +198,6 @@ SUBROUTINE ReadSzRz( zMin, zMax, myThid ) Pos%wr = 0 Pos%irz = 0 - ! *** Check for Sz/Rz in water column *** -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN -!$TAF store pos%nrz,pos%nsz,pos%rz,pos%sz = readszrz1 - IF ( ANY( Pos%Sz( 1:Pos%NSz ) < zMin ) ) THEN - WHERE ( Pos%Sz < zMin ) Pos%Sz = zMin - WRITE(msgBuf,'(2A)') 'Warning in ReadSzRz : Source above or too ',& - 'near the top bdry has been moved down' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - - IF ( ANY( Pos%Sz( 1:Pos%NSz ) > zMax ) ) THEN - WHERE( Pos%Sz > zMax ) Pos%Sz = zMax - WRITE(msgBuf,'(2A)') 'Warning in ReadSzRz : Source below or too ',& - 'near the bottom bdry has been moved up' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - - IF ( ANY( Pos%Rz( 1:Pos%NRz ) < zMin ) ) THEN - WHERE( Pos%Rz < zMin ) Pos%Rz = zMin - WRITE(msgBuf,'(2A)') 'Warning in ReadSzRz : Receiver above or too ',& - 'near the top bdry has been moved down' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - - IF ( ANY( Pos%Rz( 1:Pos%NRz ) > zMax ) ) THEN - WHERE( Pos%Rz > zMax ) Pos%Rz = zMax - WRITE(msgBuf,'(2A)') 'Warning in ReadSzRz : Receiver below or too ',& - 'near the bottom bdry has been moved up' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - ENDIF -#endif /* IHOP_WRITE_OUT */ - RETURN END !SUBROUTINE ReadSzRz @@ -353,10 +291,10 @@ SUBROUTINE ReadVector( Nx, x, Description, Units, myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - INTEGER, INTENT( IN ) :: Nx + INTEGER, INTENT( IN ) :: Nx REAL (KIND=_RL90), ALLOCATABLE, INTENT( INOUT ) :: x( : ) - CHARACTER, INTENT( IN ) :: Description*( * ), & - Units*( * ) + CHARACTER, INTENT( IN ) :: Description*( * ), & + Units*( * ) INTEGER :: ix IF ( Nx <= 0 ) THEN @@ -380,48 +318,241 @@ SUBROUTINE ReadVector( Nx, x, Description, Units, myThid ) END IF END IF + CALL SubTab( x, Nx ) + CALL Sort( x, Nx ) + + ! Vectors in km should be converted to m for internal use + IF ( LEN_TRIM( Units ) >= 2 ) THEN + IF ( Units( 1:2 ) == 'km' ) x = 1000.0 * x + END IF + + RETURN + END !SUBROUTINE ReadVector + +! ============================================================================== +! ============================================================================== + SUBROUTINE writeFreqVec( BroadbandOption, myThid ) + + ! Writes a vector of source frequencies for a broadband run + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + CHARACTER*(1), INTENT( IN ) :: BroadbandOption + INTEGER :: ifreq + + #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') + ! Broadband run? + IF ( BroadbandOption == 'B' ) THEN + WRITE(msgBuf,'(2A)')'___________________________________________',& + '________________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')'______________________________________________', & - '_____________' + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,I10)') 'Number of ' // Description // ' = ', Nx + WRITE(msgBuf,'(A,I10)') 'Number of frequencies =', Nfreq CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') Description // ' (' // Units // ')' + WRITE(msgBuf,'(A)') 'Frequencies (Hz)' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF + + WRITE( msgBuf, '(5G14.6)' ) ( freqVec( ifreq ), ifreq = 1, & + MIN( Nfreq, Number_to_Echo ) ) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + IF ( Nfreq > Number_to_Echo ) THEN + WRITE( msgBuf,'(G14.6)' ) ' ... ', freqVec( Nfreq ) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + ENDIF + ENDIF ! Broadband run + ENDIF !adjoint run? #endif /* IHOP_WRITE_OUT */ - CALL SubTab( x, Nx ) - CALL Sort( x, Nx ) + RETURN + END !SUBROUTINE writeFreqVec + + !********************************************************************! + + SUBROUTINE WriteSxSy( myThid ) + + ! Writes source x-y coordinates + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + +#ifdef IHOP_THREED +#ifdef IHOP_WRITE_OUT + CALL WriteVector( Pos%NSx, Pos%Sx, 'source x-coordinates, Sx', 'km', & + myThid ) + CALL WriteVector( Pos%NSy, Pos%Sy, 'source y-coordinates, Sy', 'km', & + myThid ) +#endif /* IHOP_WRITE_OUT */ +#endif /* IHOP_THREED */ + + RETURN + END !SUBROUTINE WriteSxSy + + !********************************************************************! + + SUBROUTINE WriteSzRz( zMin, zMax, myThid ) + + ! Writes source and receiver z-coordinates (depths) + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + REAL(KIND=_RL90), INTENT( IN ) :: zMin, zMax #ifdef IHOP_WRITE_OUT + CALL WriteVector( Pos%NSz, Pos%Sz, 'Source depths, Sz', 'm', & + myThid ) + CALL WriteVector( Pos%NRz, Pos%Rz, 'Receiver depths, Rz', 'm', & + myThid ) + + ! *** Check for Sz/Rz in water column *** ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(5G14.6)') ( x( ix ), ix = 1, MIN( Nx, Number_to_Echo ) ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - IF ( Nx > Number_to_Echo ) THEN - WRITE(msgBuf,'(G14.6)') ' ... ', x( Nx ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + IF ( ANY( Pos%Sz( 1:Pos%NSz ) < zMin ) ) THEN + WHERE ( Pos%Sz < zMin ) Pos%Sz = zMin + WRITE(msgBuf,'(2A)') 'Warning in WriteSzRz : Source above or too ',& + 'near the top bdry has been moved down' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END IF - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + IF ( ANY( Pos%Sz( 1:Pos%NSz ) > zMax ) ) THEN + WHERE( Pos%Sz > zMax ) Pos%Sz = zMax + WRITE(msgBuf,'(2A)') 'Warning in WriteSzRz : Source below or too ',& + 'near the bottom bdry has been moved up' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF + + IF ( ANY( Pos%Rz( 1:Pos%NRz ) < zMin ) ) THEN + WHERE( Pos%Rz < zMin ) Pos%Rz = zMin + WRITE(msgBuf,'(2A)') 'Warning in WriteSzRz : Receiver above or too ',& + 'near the top bdry has been moved down' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF + + IF ( ANY( Pos%Rz( 1:Pos%NRz ) > zMax ) ) THEN + WHERE( Pos%Rz > zMax ) Pos%Rz = zMax + WRITE(msgBuf,'(2A)') 'Warning in WriteSzRz : Receiver below or too ',& + 'near the bottom bdry has been moved up' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF ENDIF #endif /* IHOP_WRITE_OUT */ - ! Vectors in km should be converted to m for internal use - IF ( LEN_TRIM( Units ) >= 2 ) THEN - IF ( Units( 1:2 ) == 'km' ) x = 1000.0 * x - END IF + RETURN + END !SUBROUTINE WriteSzRz + + !********************************************************************! + + SUBROUTINE WriteRcvrRanges( myThid ) + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + REAL(KIND=_RL90) :: x(SIZE(Pos%Rr)) + + x = Pos%Rr / 1000.0 + +#ifdef IHOP_WRITE_OUT + ! IESCO22: assuming receiver positions are equally spaced + CALL WriteVector( Pos%NRr, x, 'Receiver ranges, Rr', 'km', myThid ) +#endif + + RETURN + END !SUBROUTINE WriteRcvrRanges + + !********************************************************************! + +#ifdef IHOP_THREED + SUBROUTINE WriteRcvrBearings( myThid ) ! for 3D bellhop + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + +! IEsco23: NOT SUPPORTED IN ihop + CALL WriteVector( Pos%Ntheta, Pos%theta, 'receiver bearings, theta', & + 'degrees', myThid ) + + RETURN + END !SUBROUTINE WriteRcvrBearings +#endif /* IHOP_THREED */ + !********************************************************************! + + SUBROUTINE WriteVector( Nx, x, Description, Units, myThid ) + + ! Read a vector x + ! Description is something like 'receiver ranges' + ! Units is something like 'km' + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT( IN ) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + INTEGER, INTENT( IN ) :: Nx + REAL (KIND=_RL90), INTENT( INOUT ) :: x( : ) + CHARACTER, INTENT( IN ) :: Description*( * ), Units*( * ) + INTEGER :: ix + +#ifdef IHOP_WRITE_OUT + ! In adjoint mode we do not write output besides on the first run + IF (IHOP_dumpfreq.GE.0) THEN + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)')'______________________________________________', & + '_____________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A,I10)') 'Number of ' // Description // ' = ', Nx + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + WRITE(msgBuf,'(A)') Description // ' (' // Units // ')' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + + WRITE(msgBuf,'(5G14.6)') ( x( ix ), ix = 1, MIN( Nx, Number_to_Echo ) ) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + IF ( Nx > Number_to_Echo ) THEN + WRITE(msgBuf,'(G14.6)') ' ... ', x( Nx ) + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END IF + + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + ENDIF +#endif /* IHOP_WRITE_OUT */ RETURN - END !SUBROUTINE ReadVector + END !SUBROUTINE WriteVector END MODULE srpos_mod diff --git a/src/ssp_mod.F90 b/src/ssp_mod.F90 index 22301f8..836846c 100644 --- a/src/ssp_mod.F90 +++ b/src/ssp_mod.F90 @@ -30,7 +30,7 @@ MODULE ssp_mod ! public interfaces !======================================================================= - public initSSP, evalSSP, SSP, alphaR, betaR, & + public initSSP, setSSP, evalSSP, SSP, alphaR, betaR, & alphaI, betaI, rhoR, iSegz, iSegr !======================================================================= @@ -42,9 +42,9 @@ MODULE ssp_mod EXTERNAL CHEN_MILLERO ! LOCAL VARIABLES -! == Local Variables == - INTEGER bi,bj - INTEGER i,j +!! == Local Variables == +! INTEGER bi,bj +! INTEGER i,j ! LEGACY VARIABLES ! == Legacy Local Variables == @@ -68,7 +68,10 @@ MODULE ssp_mod ! TYPE STRUCTURES ! == Type Structures == TYPE rxyz_vector - REAL (KIND=_RL90), ALLOCATABLE :: r(:), x(:), y(:), z(:) + REAL (KIND=_RL90), ALLOCATABLE :: r(:) +#ifdef IHOP_THREED + REAL (KIND=_RL90), ALLOCATABLE :: x(:), y(:), z(:) +#endif END TYPE rxyz_vector ! SSP @@ -94,7 +97,45 @@ SUBROUTINE initSSP( x, myThid ) ! Call the particular profile routine indicated by the SSP%Type and ! perform initialize SSP structures - USE ihop_mod, only: SSPFile +! USE ihop_mod, only: SSPFile +! USE pchip_mod, only: PCHIP +! USE splinec_mod,only: cspline + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + INTEGER, INTENT( IN ) :: myThid +! CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point +! INTEGER :: ir, iz +! +!!$TAF init initssp1 = 'ssp_mod_initssp' +! +!! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +!! Scalar components +!! Fixed arrays +!! Allocatable arrays +!!$TAF store ssp%cmat,ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = initssp1 +! + ! All methods require Depth + Depth = x( 2 ) + ! Check if SSPFile exists + IF (useSSPFile) THEN + CALL ReadSSP( Depth, myThid ) + ELSE + CALL init_fixed_SSP( myThid ) + END IF + + RETURN + END !SUBROUTINE initSSP + +!**********************************************************************! + SUBROUTINE setSSP( x, myThid ) + + ! Call the particular profile routine indicated by the SSP%Type and + ! set SSP structures + USE pchip_mod, only: PCHIP USE splinec_mod,only: cspline @@ -105,16 +146,16 @@ SUBROUTINE initSSP( x, myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point + REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point INTEGER :: ir, iz -!$TAF init initssp1 = 'ssp_mod_initssp' - -! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod -! Scalar components -! Fixed arrays -! Allocatable arrays -!$TAF store ssp%cmat,ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = initssp1 +!!$TAF init setssp1 = 'ssp_mod_setssp' +! +!! IESCO24: Write derived type with allocatable memory by type: SSP from ssp_mod +!! Scalar components +!! Fixed arrays +!! Allocatable arrays +!!$TAF store ssp%cmat,ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = setssp1 ! init defaults for ssp_mod scoped arrays n2 = (-1.,-1.) @@ -123,14 +164,14 @@ SUBROUTINE initSSP( x, myThid ) cCoef = (-1.,-1.) ! All methods require Depth - Depth = x( 2 ) - ! Check if SSPFile exists + Depth = x(2) IF (useSSPFile) THEN - CALL ReadSSP( Depth, myThid ) + CALL ReadSSP( Depth, myThid ) ELSE - CALL ExtractSSP(Depth, myThid ) - END IF + CALL ExtractSSP( Depth, myThid ) + ENDIF + ! Populate rest of SSP derived type based on SSP interpolation scheme SELECT CASE ( SSP%Type ) CASE ( 'N' ) ! N2-linear profile option n2( 1:SSP%NPts ) = 1.0 / SSP%c( 1:SSP%NPts )**2 @@ -174,20 +215,16 @@ SUBROUTINE initSSP( x, myThid ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'Profile option: ', SSP%Type - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') 'SSPMOD initSSP: Invalid SSP profile option' + WRITE(msgBuf,'(A)') 'SSPMOD setSSP: Invalid SSP profile option' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R initSSP' + STOP 'ABNORMAL END: S/R setSSP' END SELECT + RETURN - END !SUBROUTINE initSSP + END !SUBROUTINE setSSP !**********************************************************************! - SUBROUTINE evalSSP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! Call the particular profile routine indicated by the SSP%Type and @@ -237,7 +274,6 @@ SUBROUTINE evalSSP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) END !SUBROUTINE evalSSP !**********************************************************************! - SUBROUTINE n2Linear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! N2-linear interpolation of SSP data @@ -282,8 +318,7 @@ SUBROUTINE n2Linear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) RETURN END !SUBROUTINE n2Linear - !**********************************************************************! - +!**********************************************************************! SUBROUTINE cLinear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! c-linear interpolation of SSP data @@ -293,38 +328,37 @@ SUBROUTINE cLinear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) INTEGER, INTENT( IN ) :: myThid ! == Local Variables == - REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point + REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point ! sound speed and its derivatives - REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, rho + REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, rho iSegz = 1 !RG - IF ( x( 2 ) < SSP%z( iSegz ) .OR. x( 2 ) > SSP%z( iSegz+1 ) ) THEN + IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. !IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths - IF ( x( 2 ) < SSP%z( iz ) .and. .not. foundz ) THEN + IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN iSegz = iz - 1 foundz = .true. END IF END DO END IF - c = REAL( SSP%c( iSegz ) + ( x( 2 ) - SSP%z( iSegz ) ) * SSP%cz( iSegz ) ) - cimag = AIMAG( SSP%c( iSegz ) + ( x( 2 ) - SSP%z( iSegz ) ) * SSP%cz( iSegz ) ) + c = REAL( SSP%c( iSegz ) + ( x(2) - SSP%z( iSegz ) ) * SSP%cz( iSegz ) ) + cimag = AIMAG( SSP%c( iSegz ) + ( x(2) - SSP%z( iSegz ) ) * SSP%cz( iSegz ) ) gradc = [ 0.0D0, REAL( SSP%cz( iSegz ) ) ] crr = 0.0d0 crz = 0.0d0 czz = 0.0d0 - W = ( x( 2 ) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) + W = ( x(2) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) RETURN END !SUBROUTINE cLinear - !**********************************************************************! - +!**********************************************************************! SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! This implements the monotone piecewise cubic Hermite interpolating @@ -336,20 +370,20 @@ SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) INTEGER, INTENT( IN ) :: myThid ! == Local Variables == - REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point - REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, & + REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point + REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, & rho ! sound speed and its derivatives REAL (KIND=_RL90) :: xt COMPLEX (KIND=_RL90) :: c_cmplx iSegz = 1 !RG - IF ( x( 2 ) < SSP%z( iSegz ) .OR. x( 2 ) > SSP%z( iSegz+1 ) ) THEN + IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. !IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths - IF ( x( 2 ) < SSP%z( iz ) .and. .not. foundz ) THEN + IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN iSegz = iz - 1 foundz = .true. END IF @@ -374,16 +408,14 @@ SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) czz = REAL( 2.0D0 * cCoef( 3, iSegz ) + & 6.0D0 * cCoef( 4, iSegz ) * xt ) ! dgradc(2)/dxt - W = ( x( 2 ) - SSP%z( iSegz ) ) / & - ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) + W = ( x(2) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) ! linear interp of density rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) RETURN END !SUBROUTINE cPCHIP - !**********************************************************************! - +!**********************************************************************! SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! Cubic spline interpolation @@ -395,8 +427,8 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) INTEGER, INTENT( IN ) :: myThid ! == Local Variables == - REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point - REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, & + REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point + REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, & rho ! sound speed and its derivatives REAL (KIND=_RL90) :: hSpline COMPLEX (KIND=_RL90) :: c_cmplx, cz_cmplx, czz_cmplx @@ -404,19 +436,19 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! *** Section to return SSP info *** iSegz = 1 !RG - IF ( x( 2 ) < SSP%z( iSegz ) .OR. x( 2 ) > SSP%z( iSegz+1 ) ) THEN + IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. !IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths - IF ( x( 2 ) < SSP%z( iz ) .and. .not. foundz ) THEN + IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN iSegz = iz - 1 foundz = .true. END IF END DO END IF - hSpline = x( 2 ) - SSP%z( iSegz ) + hSpline = x(2) - SSP%z( iSegz ) CALL SplineALL( cSpln( 1, iSegz ), hSpline, c_cmplx, cz_cmplx, czz_cmplx ) @@ -428,14 +460,13 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) crz = 0.0d0 ! linear interpolation for density - W = ( x( 2 ) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) + W = ( x(2) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) RETURN END !SUBROUTINE cCubic !**********************************************************************! - SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! Bilinear quadrilatteral interpolation of SSP data in 2D, SSP%Type = 'Q' @@ -446,8 +477,8 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) CHARACTER*(MAX_LEN_MBUF):: msgBuf ! == Local Variables == - REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point - REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, & + REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point + REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, & rho ! sound speed and its derivatives INTEGER :: irT, iz2 INTEGER :: isegzold @@ -458,10 +489,10 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! IESCO22: iSegz is the depth index containing x depth ! find depth-layer where x(2) in ( SSP%z( iSegz ), SSP%z( iSegz+1 ) ) iSegz = 1 !RG - IF ( x( 2 ) < SSP%z( iSegz ) .OR. x( 2 ) > SSP%z( iSegz+1 ) ) THEN + IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. DO iz = 2, SSP%Nz ! Search for bracketting Depths - IF ( x( 2 ) < SSP%z( iz ) .and. .not. foundz ) THEN + IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN iSegz = iz - 1 foundz = .true. END IF @@ -469,7 +500,7 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) END IF ! Check that x is inside the box where the sound speed is defined - IF ( x( 1 ) < SSP%Seg%r( 1 ) .OR. x( 1 ) > SSP%Seg%r( SSP%Nr ) ) THEN + IF ( x(1) < SSP%Seg%r( 1 ) .OR. x(1) > SSP%Seg%r( SSP%Nr ) ) THEN #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN @@ -488,10 +519,10 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! find range-segment where x(1) in [ SSP%Seg%r( iSegr ), SSP%Seg%r( iSegr+1 ) ) iSegr = 1 !RG - IF ( x( 1 ) < SSP%Seg%r( iSegr ) .OR. x( 1 ) >= SSP%Seg%r( iSegr+1 ) ) THEN + IF ( x(1) < SSP%Seg%r( iSegr ) .OR. x(1) >= SSP%Seg%r( iSegr+1 ) ) THEN foundr=.false. DO irT = 2, SSP%Nr ! Search for bracketting segment ranges - IF ( x( 1 ) < SSP%Seg%r( irT ) .and. .not. foundr ) THEN + IF ( x(1) < SSP%Seg%r( irT ) .and. .not. foundr ) THEN iSegr = irT - 1 foundr=.true. END IF @@ -503,7 +534,7 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) cz2 = SSP%czMat( iSegz, iSegr+1 ) !IESCO22: s2 is distance btwn field point, x(2), and ssp depth @ iSegz - s2 = x( 2 ) - SSP%z( iSegz ) + s2 = x(2) - SSP%z( iSegz ) delta_z = SSP%z( iSegz+1 ) - SSP%z( iSegz ) IF (delta_z <= 0 .OR. s2 > delta_z) THEN #ifdef IHOP_WRITE_OUT @@ -521,7 +552,7 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! s1 = proportional distance of x(1) in range delta_r = SSP%Seg%r( iSegr+1 ) - SSP%Seg%r( iSegr ) - s1 = ( x( 1 ) - SSP%Seg%r( iSegr ) ) / delta_r + s1 = ( x(1) - SSP%Seg%r( iSegr ) ) / delta_r ! piecewise constant extrapolation for ranges outside SSP box s1 = MIN( s1, 1.0D0 ) s1 = MAX( s1, 0.0D0 ) @@ -543,7 +574,7 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) czz = 0.0 ! linear interpolation for density - W = ( x( 2 ) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) + W = ( x(2) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) !IESCO22: for thesis, czz=crr=0, and rho=1 at all times @@ -551,7 +582,6 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) END !SUBROUTINE Quad !**********************************************************************! - SUBROUTINE ReadSSP( Depth, myThid ) ! reads SSP in m/s from .ssp file and convert to AttenUnit (ie. Nepers/m) ! Populates SSPStructure: SSP @@ -571,12 +601,11 @@ SUBROUTINE ReadSSP( Depth, myThid ) ! == Local Variables == REAL (KIND=_RL90), INTENT(IN) :: Depth - INTEGER :: iz2 REAL (KIND=_RL90) :: bPower, fT - ! IESCO24 fT init - bPower = 1.0 - fT = 1000.0 + ! IESCO24 fT init + bPower = 1.0 + fT = 1000.0 ! I/O on main thread only _BEGIN_MASTER(myThid) @@ -585,49 +614,17 @@ SUBROUTINE ReadSSP( Depth, myThid ) FORM = 'FORMATTED', STATUS = 'OLD', IOSTAT = iostat ) IF ( IOSTAT /= 0 ) THEN ! successful open? #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'SSPFile = ', TRIM(IHOP_fileroot) // '.ssp' - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + !WRITE(msgBuf,'(A)') 'SSPFile = ', TRIM(IHOP_fileroot) // '.ssp' + !! In adjoint mode we do not write output besides on the first run + !IF (IHOP_dumpfreq.GE.0) & + ! CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'SSPMOD ReadSSP: Unable to open the SSP file' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R ReadSSP' END IF - ! Write relevant diagnostics -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') "Sound Speed Field" - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')'_______________________________________________',& - '____________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ - READ( SSPFile, * ) SSP%Nr, SSP%Nz -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - IF (SSP%Nr .GT. 1) THEN - WRITE(msgBuf,'(A)') 'Using range-dependent sound speed' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - IF (SSP%Nr .EQ. 1) THEN - WRITE(msgBuf,'(A)') 'Using range-independent sound speed' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - END IF - - WRITE(msgBuf,'(A,I10)') 'Number of SSP ranges = ', SSP%Nr - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A,I10)') 'Number of SSP depths = ', SSP%Nz - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ ALLOCATE( SSP%cMat( SSP%Nz, SSP%Nr ), & SSP%czMat( SSP%Nz-1, SSP%Nr ), & @@ -642,94 +639,19 @@ SUBROUTINE ReadSSP( Depth, myThid ) STOP 'ABNORMAL END: S/R ReadSSP' END IF - READ( SSPFile, * ) SSP%Seg%r( 1 : SSP%Nr ) -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') 'Profile ranges (km):' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(F10.2)') SSP%Seg%r( 1 : SSP%Nr ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ + READ( SSPFile, * ) SSP%Seg%r( 1:SSP%Nr ) SSP%Seg%r = 1000.0 * SSP%Seg%r ! convert km to m - READ( SSPFile, * ) SSP%z( 1 : SSP%Nz ) -!#ifdef IHOP_DEBUG -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') 'Profile depths (m):' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(F10.2)') SSP%z( 1 : SSP%Nz ) - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ -!#endif + READ( SSPFile, * ) SSP%z( 1:SSP%Nz ) - ! IEsco23: contain read of ssp in this subroutine only - ! IEsco23: change to allocatable memory since we should know Nz -#ifdef IHOP_DEBUG -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') 'Sound speed matrix:' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') ' Depth (m ) Soundspeed (m/s)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ -#endif /* IHOP_DEBUG */ - DO iz2 = 1, SSP%Nz - READ( SSPFile, * ) SSP%cMat( iz2, : ) -#ifdef IHOP_DEBUG -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(12F10.2)') SSP%z( iz2 ), SSP%cMat( iz2, : ) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ -#endif /* IHOP_DEBUG */ + DO iz = 1, SSP%Nz + READ( SSPFile, * ) SSP%cMat( iz, : ) END DO CLOSE( SSPFile ) -#ifdef IHOP_WRITE_OUT - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') 'Sound speed profile:' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')' z alphaR betaR rho ',& - ' alphaI betaI' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)')' (m) (m/s) (m/s) (g/cm^3) ',& - ' (m/s) (m/s)' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - - WRITE(msgBuf,'(2A)')'_______________________________________________',& - '____________' - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - ENDIF -#endif /* IHOP_WRITE_OUT */ SSP%NPts = 1 DO iz = 1, MaxSSP alphaR = SSP%cMat( iz, 1 ) -#ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'( F10.2, 3X, 2F10.2, 3X, F6.2, 3X, 2F10.4)') & - SSP%z( iz ), alphaR, betaR, rhoR, alphaI, betaI - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) -#endif /* IHOP_WRITE_OUT */ SSP%c(iz) = CRCI( SSP%z(iz), alphaR, alphaI, SSP%AttenUnit, bPower, fT, & myThid ) @@ -739,12 +661,9 @@ SUBROUTINE ReadSSP( Depth, myThid ) IF ( iz > 1 ) THEN IF ( SSP%z( iz ) .LE. SSP%z( iz-1 ) ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A,F10.2)') 'Bad depth in SSP: ', SSP%z( iz ) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(2A)') 'SSPMOD ReadSSP: ', & - 'The depths in the SSP must be monotone increasing' + WRITE(msgBuf,'(2A,F10.2)') 'SSPMOD ReadSSP: ', & + 'The depths in the SSP must be monotone increasing', & + SSP%z(iz) CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R ReadSSP' @@ -752,17 +671,13 @@ SUBROUTINE ReadSSP( Depth, myThid ) END IF ! compute gradient, cz - IF ( iz > 1 ) SSP%cz( iz - 1 ) = ( SSP%c( iz ) - SSP%c( iz-1 ) ) / & + IF ( iz > 1 ) SSP%cz( iz-1 ) = ( SSP%c( iz ) - SSP%c( iz-1 ) ) / & ( SSP%z( iz ) - SSP%z( iz-1 ) ) ! Did we read the last point? IF ( ABS( SSP%z( iz ) - Depth ) < 100. * EPSILON( 1.0e0 ) ) THEN IF ( SSP%NPts == 1 ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A,I10)') '#SSP points: ', SSP%NPts - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)') 'SSPMOD ReadSSP: ', & 'The SSP must have at least 2 points' CALL PRINT_ERROR( msgBuf,myThid ) @@ -770,6 +685,9 @@ SUBROUTINE ReadSSP( Depth, myThid ) STOP 'ABNORMAL END: S/R ReadSSP' END IF + ! Write to PRTFile + CALL writeSSP( myThid ) + RETURN ENDIF @@ -778,10 +696,6 @@ SUBROUTINE ReadSSP( Depth, myThid ) ! Fall through means too many points in the profile #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A,I10)') 'Max. #SSP points: ', MaxSSP - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)') 'SSPMOD ReadSSP: ', & 'Number of SSP points exceeds limit' CALL PRINT_ERROR( msgBuf,myThid ) @@ -794,7 +708,6 @@ SUBROUTINE ReadSSP( Depth, myThid ) END !SUBROUTINE ReadSSP !**********************************************************************! - SUBROUTINE ExtractSSP( Depth, myThid ) ! Extracts SSP from MITgcm grid points @@ -813,113 +726,51 @@ SUBROUTINE ExtractSSP( Depth, myThid ) CHARACTER*(80) :: fmtstr ! == Local Variables == - INTEGER :: ii, jj, k - INTEGER :: njj(IHOP_NPTS_RANGE), nii(IHOP_NPTS_RANGE) + LOGICAL :: found_interpolation + INTEGER :: iallocstat + INTEGER :: bi,bj, i,j,k, ii,jj + INTEGER :: njj(IHOP_NPTS_RANGE) REAL (KIND=_RL90), INTENT(IN) :: Depth - REAL (KIND=_RL90) :: sumweights(IHOP_NPTS_RANGE, Nr), & - dcdz, tolerance + REAL (KIND=_RL90) :: dcdz, tolerance REAL (KIND=_RL90), ALLOCATABLE:: tmpSSP(:,:,:,:) - LOGICAL :: found_interpolation, skip_range REAL (KIND=_RL90) :: bPower, fT ! IESCO24 fT init bPower = 1.0 fT = 1000.0 - SSP%Nz = Nr+2 ! add z=0 z=Depth layers - SSP%Nr = IHOP_NPTS_RANGE + ! init local vars + found_interpolation =.false. + njj(:) = 0 + dcdz = 0.0 _d 0 + tolerance = 5 _d -5 - ALLOCATE( SSP%cMat( SSP%Nz, SSP%Nr ), & - SSP%czMat( SSP%Nz-1, SSP%Nr ), & - SSP%Seg%r( SSP%Nr ), tmpSSP(SSP%Nz,SSP%Nr,nSx,nSy), & - STAT = iallocstat ) + IF(ALLOCATED(tmpSSP)) DEALLOCATE(tmpSSP) + ALLOCATE( tmpSSP(SSP%Nz,SSP%Nr,nSx,nSy), STAT = iallocstat ) IF ( iallocstat /= 0 ) THEN # ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(2A)') 'SSPMOD ExtractSSP: ', & - 'Insufficient memory to store SSP' + 'Insufficient memory to store tmpSSP' CALL PRINT_ERROR( msgBuf,myThid ) # endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R ExtractSSP' END IF - ! Initiate to ceros - SSP%cMat = 0.0 _d 0 tmpSSP = 0.0 _d 0 - njj(:) = 0 - dcdz = 0.0 _d 0 - tolerance = 5 _d -5 - - ! set SSP%Seg%r from data.ihop -> ihop_ranges - SSP%Seg%r( 1:SSP%Nr ) = ihop_ranges( 1:SSP%Nr ) - - ! set SSP%z from rC, rkSign=-1 used bc ihop uses +ive depths - SSP%z( 1 ) = 0.0 _d 0 - SSP%z( 2:(SSP%Nz-1) ) = rkSign*rC( 1:Nr ) - SSP%z( SSP%Nz ) = Bdry%Bot%HS%Depth ! rkSign*rF(Nr+1)*1.05 - - !================================================== - ! IDW Interpolate: COMPARING with LAT LONs (xC, yC) - !================================================== - ! Sum IDW weights - DO ii = 1,IHOP_npts_range - sumweights(ii,:) = sum(ihop_idw_weights(ii,:)) - END DO - - ! Adapt IDW interpolation by bathymetry - DO bj=myByLo(myThid),myByHi(myThid) - DO bi=myBxLo(myThid),myBxHi(myThid) - DO j=1,sNy - DO i=1,sNx - DO ii=1,IHOP_npts_range - skip_range = .FALSE. - - DO jj=1,IHOP_npts_idw - IF (ABS(xC(i, j, bi, bj) - ihop_xc(ii, jj)) .LE. tolerance .AND. & - ABS(yC(i, j, bi, bj) - ihop_yc(ii, jj)) .LE. tolerance) THEN - DO k=1,Nr - ! No IDW interpolation on xc, yc centered ranges - IF (nii(ii) .EQ. 1 .AND. k .GT. njj(ii)) THEN - skip_range = .TRUE. - END IF - - IF (.NOT. skip_range) THEN - IF (hFacC(i, j, k, bi, bj) .EQ. 0.0) THEN - sumweights(ii, k) = sumweights(ii, k) - ihop_idw_weights(ii, jj) - - ! No interpolation on xc, yc centered ranges - IF (ihop_idw_weights(ii, jj) .EQ. 0.0) THEN - sumweights(ii, k:Nr) = 0.0 - nii(ii) = 1 - njj(ii) = k - END IF - END IF - - ! Set TINY and negative values to 0.0 - IF (sumweights(ii, k) .LT. 1D-13) sumweights(ii, k) = 0.0 - END IF - END DO - END IF - END DO - END DO - END DO - END DO - ENDDO - ENDDO - - ! Initiate to ceros - njj(:) = 0 ! interpolate SSP with adaptive IDW from gcm grid to ihop grid DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) !$TAF INIT tape_ssp1 = static, 100 !RG !$TAF INIT tape_ssp2 = static, 100 !RG + DO j=1,sNy DO i=1,sNx DO ii=1,IHOP_npts_range found_interpolation = .FALSE. DO jj=1,IHOP_npts_idw !$TAF STORE found_interpolation = tape_ssp1 !RG + ! Interpolate from GCM grid cell centers IF (ABS(xC(i, j, bi, bj) - ihop_xc(ii, jj)) .LE. tolerance .AND. & ABS(yC(i, j, bi, bj) - ihop_yc(ii, jj)) .LE. tolerance .AND. & @@ -928,55 +779,58 @@ SUBROUTINE ExtractSSP( Depth, myThid ) DO iz = 1, SSP%Nz - 1 !$TAF STORE tmpSSP(:,ii,bi,bj),njj(ii) = tape_ssp2 !RG - IF (iz .EQ. 1) THEN - ! Top vlevel zero depth - tmpSSP(1, ii, bi, bj) = tmpSSP(1, ii, bi, bj) + & - CHEN_MILLERO(i, j, 0, bi, bj, myThid) * & - ihop_idw_weights(ii, jj) / sumweights(ii, iz) - ELSE ! 2:(SSP%Nz-1) - ! Middle depth layers, only when not already underground - IF (sumweights(ii, iz - 1) .GT. 0.0) THEN -!$TAF STORE njj(ii) = tape_ssp2 !RG - ! Exactly on a cell center, ignore interpolation - IF (ihop_idw_weights(ii, jj) .EQ. 0.0) THEN - tmpSSP(iz, ii, bi, bj) = ihop_ssp(i, j, iz-1, bi, bj) - njj(ii) = IHOP_npts_idw + 1 - - ! Apply IDW interpolation - ELSE IF (njj(ii) .LE. IHOP_npts_idw) THEN - tmpSSP(iz, ii, bi, bj) = tmpSSP(iz, ii, bi, bj) + & - ihop_ssp(i, j, iz - 1, bi, bj) * & - ihop_idw_weights(ii, jj) / sumweights(ii, iz-1) - END IF - END IF - - ! Extrapolate through bathymetry; don't interpolate - IF (iz .EQ. SSP%Nz-1 .OR. sumweights(ii, iz-1) .EQ. 0.0) THEN - k = iz - - IF (njj(ii) .GE. IHOP_npts_idw) THEN - ! Determine if you are at the last vlevel - IF (iz .EQ. SSP%Nz-1 .AND. sumweights(ii, iz-1) .NE. 0.0) k = k + 1 - - ! Calc depth gradient - dcdz = (tmpSSP(k-1, ii, bi, bj) - tmpSSP(k-2, ii, bi, bj)) / & - (SSP%z(k-1) - SSP%z(k-2)) - ! Extrapolate - tmpSSP(k:SSP%Nz, ii, bi, bj) = & - tmpSSP(k-1, ii, bi, bj) + dcdz * SSP%z(k:SSP%Nz) - ! Move to next range point, ii - found_interpolation = .TRUE. - END IF - END IF - END IF - END DO + + IF (iz .EQ. 1) THEN + ! Top vlevel zero depth + tmpSSP(1, ii, bi, bj) = tmpSSP(1, ii, bi, bj) + & + CHEN_MILLERO(i, j, 0, bi, bj, myThid) * & + ihop_idw_weights(ii, jj) / ihop_sumweights(ii, iz) + ELSE ! 2:(SSP%Nz-1) + ! Middle depth layers, only when not already underground + IF (ihop_sumweights(ii, iz - 1) .GT. 0.0) THEN +!$TAF store njj(ii) = tape_ssp2 !RG + + ! Exactly on a cell center, ignore interpolation + IF (ihop_idw_weights(ii, jj) .EQ. 0.0) THEN + tmpSSP(iz, ii, bi, bj) = ihop_ssp(i, j, iz-1, bi, bj) + njj(ii) = IHOP_npts_idw + 1 + + ! Apply IDW interpolation + ELSE IF (njj(ii) .LE. IHOP_npts_idw) THEN + tmpSSP(iz, ii, bi, bj) = tmpSSP(iz, ii, bi, bj) + & + ihop_ssp(i, j, iz - 1, bi, bj) * & + ihop_idw_weights(ii, jj) / ihop_sumweights(ii, iz-1) + END IF + END IF + + ! Extrapolate through bathymetry; don't interpolate + IF (iz .EQ. SSP%Nz-1 .OR. ihop_sumweights(ii, iz-1) .EQ. 0.0) THEN + k = iz + + IF (njj(ii) .GE. IHOP_npts_idw) THEN + ! Determine if you are at the last vlevel + IF (iz .EQ. SSP%Nz-1 .AND. ihop_sumweights(ii, iz-1) .NE. 0.0) & + k = k + 1 + + ! Calc depth gradient + dcdz = (tmpSSP(k-1, ii, bi, bj) - tmpSSP(k-2, ii, bi, bj)) / & + (SSP%z(k-1) - SSP%z(k-2)) + ! Extrapolate + tmpSSP(k:SSP%Nz, ii, bi, bj) = & + tmpSSP(k-1, ii, bi, bj) + dcdz * SSP%z(k:SSP%Nz) + ! Move to next range point, ii + found_interpolation = .TRUE. + END IF + END IF + END IF + END DO !iz END IF - END DO - END DO - END DO - END DO - ENDDO - ENDDO + END DO !jj + END DO !ii + END DO !i + END DO !j + END DO !bi + END DO !bj IF ((nPx.GT.1) .OR. (nPy.GT.1)) THEN CALL GLOBAL_VEC_SUM_R8(SSP%Nz*SSP%Nr,SSP%Nz*SSP%Nr,tmpSSP,myThid) @@ -988,61 +842,55 @@ SUBROUTINE ExtractSSP( Depth, myThid ) !================================================== ! set vector structured c, rho, and cz for first range point - DO iz = 1,SSP%Nz - alphaR = SSP%cMat( iz, 1 ) + IF (.not. useSSPFile ) THEN ! if usessp, these have already been set + DO iz = 1,SSP%Nz + alphaR = SSP%cMat( iz, 1 ) - SSP%c(iz) = CRCI( SSP%z(iz), alphaR, alphaI, SSP%AttenUnit, bPower, fT, & - myThid ) - SSP%rho(iz) = rhoR + SSP%c(iz) = CRCI( SSP%z(iz), alphaR, alphaI, SSP%AttenUnit, bPower, fT, & + myThid ) + SSP%rho(iz) = rhoR - IF ( iz > 1 ) THEN - IF ( SSP%z( iz ) .LE. SSP%z( iz-1 ) ) THEN -# ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') 'Bad depth in SSP: ', SSP%z(iz) - ! In adjoint mode we do not write output besides on the first run - IF (IHOP_dumpfreq.GE.0) & - CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE( msgBuf,'(2A)' ) 'SSPMOD ExtractSSP: ', & - 'The depths in the SSP must be monotone increasing' - CALL PRINT_ERROR( msgBuf,myThid ) -# endif /* IHOP_WRITE_OUT */ - STOP 'ABNORMAL END: S/R ExtractSSP' + IF ( iz > 1 ) THEN + IF ( SSP%z( iz ) .LE. SSP%z( iz-1 ) ) THEN +#ifdef IHOP_WRITE_OUT + WRITE( msgBuf,'(2A)' ) 'SSPMOD ExtractSSP: ', & + 'The depths in the SSP must be monotone increasing' + CALL PRINT_ERROR( msgBuf,myThid ) +#endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R ExtractSSP' + END IF END IF - END IF - ! Compute gradient, cz - IF ( iz>1 ) SSP%cz( iz-1 ) = ( SSP%c( iz ) - SSP%c( iz-1 ) ) / & - ( SSP%z( iz ) - SSP%z( iz-1 ) ) - END DO + ! Compute gradient, cz + IF ( iz>1 ) SSP%cz( iz-1 ) = ( SSP%c( iz ) - SSP%c( iz-1 ) ) / & + ( SSP%z( iz ) - SSP%z( iz-1 ) ) + END DO + END IF ! Write to PRTFile CALL writeSSP( myThid ) - ! Modify from [m] to [km] - SSP%Seg%r = 1000.0 * SSP%Seg%r - RETURN END !SUBROUTINE ExtractSSP - +!**********************************************************************! SUBROUTINE writeSSP( myThid ) ! Extracts SSP from MITgcm grid points - - USE ihop_mod, only: PRTFile + USE ihop_mod, only: PRTFile ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. - INTEGER, INTENT(IN) :: myThid + INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - CHARACTER*(80) :: fmtstr ! == Local Variables == - INTEGER :: k - REAL (KIND=_RL90) :: sspcmat(SSP%Nr) + INTEGER :: iz + CHARACTER*(80) :: fmtstr + REAL (KIND=_RL90) :: ssptmp(SSP%Nr) ! init local vars - sspcmat = 0.0 + ssptmp = 0.0 ! I/O on main thread only _BEGIN_MASTER(myThid) @@ -1050,6 +898,7 @@ SUBROUTINE writeSSP( myThid ) #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN + ! Write relevant diagnostics WRITE(msgBuf,'(2A)')'________________________________________________', & '___________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -1060,11 +909,16 @@ SUBROUTINE writeSSP( myThid ) WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - IF (SSP%Nr.GT.1) THEN + WRITE(msgBuf,'(2A)') 'Profile option: ', SSP%Type + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + IF (SSP%Nr .GT. 1) THEN WRITE(msgBuf,'(A)') 'Using range-dependent sound speed' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END IF - IF (SSP%Nr.EQ.1) THEN + IF (SSP%Nr .EQ. 1) THEN WRITE(msgBuf,'(A)') 'Using range-independent sound speed' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END IF @@ -1076,23 +930,53 @@ SUBROUTINE writeSSP( myThid ) WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') 'Profile ranges (km):' + WRITE(msgBuf,'(A)') 'Profile ranges [km]:' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(fmtStr,'(A,I10,A)') '(T11,',SSP%Nr, 'F10.2)' - WRITE(msgBuf,fmtStr) SSP%Seg%r( 1:SSP%Nr ) + ssptmp = SSP%Seg%R( 1:SSP%Nr ) / 1000.0 + WRITE(msgBuf,fmtStr) ssptmp CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Sound speed matrix:' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') ' Depth (m) Soundspeed (m/s)' + WRITE(msgBuf,'(A)') ' Depth [m ] Soundspeed [m/s]' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - DO k = 1, SSP%Nz - sspcmat = ssp%cMat( k,: ) - WRITE(msgBuf,'(12F10.2)') SSP%z( k ), sspcmat + + ssptmp = 0.0 + DO iz = 1, SSP%Nz + ssptmp = ssp%cMat( iz,: ) + WRITE(msgBuf,'(12F10.2)') SSP%z( iz ), ssptmp CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END DO - ENDIF + + IF (useSSPFile) THEN + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') 'Sound speed profile:' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)')' z alphaR betaR rho ', & + ' alphaI betaI' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(2A)')' [m] [m/s] [m/s] [g/cm^3] ', & + ' [m/s] [m/s]' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + WRITE(msgBuf,'(2A)')'_______________________________________________', & + '____________' + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + WRITE(msgBuf,'(A)') + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + + DO iz = 1, SSP%NPts + WRITE(msgBuf,'( F10.2, 3X, 2F10.2, 3X, F6.2, 3X, 2F10.4)') & + SSP%z( iz ), SSP%cMat(iz,1), betaR, rhoR, alphaI, betaI + CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) + END DO + END IF + +ENDIF ! don't write in adjoint mode #endif /* IHOP_WRITE_OUT */ ! I/O on main thread only _END_MASTER(myThid) @@ -1101,4 +985,130 @@ SUBROUTINE writeSSP( myThid ) RETURN END !SUBROUTINE writeSSP +!**********************************************************************! +SUBROUTINE init_fixed_ssp( myThid ) + ! Initiate parameters that don't change within a time series + ! Sets SSP%Nr,Nz,Seg%r, and ihop_sumweights + USE bdry_mod, only: Bdry + + ! == Routine Arguments == + ! myThid :: Thread number. Unused by IESCO + ! msgBuf :: Used to build messages for printing. + INTEGER, INTENT(IN) :: myThid + CHARACTER*(MAX_LEN_MBUF):: msgBuf + + ! == Local Variables == + LOGICAL :: skip_range + INTEGER :: iallocstat + INTEGER :: bi,bj, i,j,k, ii,jj + INTEGER :: nii(IHOP_NPTS_RANGE), njj(IHOP_NPTS_RANGE) + REAL (KIND=_RL90) :: tolerance + + ! init local vars + skip_range =.false. + nii(:) = 0 + njj(:) = 0 + tolerance = 5 _d -5 + + ! init default SSP values (only fixed memory vars) + SSP%NPts = -1 + SSP%z = -999.0 + SSP%rho = -999.0 + SSP%c = (-999.0, 0.0) + SSP%cz = (-999.0, 0.0) + + ! set ihop SSP grid size + SSP%Nz = Nr+2 ! add z=0 z=Depth layers to GCM Nr + SSP%Nr = IHOP_NPTS_RANGE + SSP%NPts = SSP%Nz + + ! set SSP%z from rC, rkSign=-1 used bc ihop uses +ive depths + SSP%z( 1 ) = 0.0 _d 0 + SSP%z( 2:(SSP%Nz-1) ) = rkSign*rC( 1:Nr ) + SSP%z( SSP%Nz ) = Bdry%Bot%HS%Depth ! rkSign*rF(Nr+1)*1.05 + + ! set SSP%Seg%r from data.ihop -> ihop_ranges + !IF (ALLOCATED(SSP%Seg%r)) DEALLOCATE(SSP%Seg%r) + ALLOCATE( SSP%Seg%r( SSP%Nr ), STAT = iallocstat ) + IF ( iallocstat /= 0 ) THEN +# ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'SSPMOD init_fixed_SSP: ', & + 'Insufficient memory to store SSP%Seg%R' + CALL PRINT_ERROR( msgBuf,myThid ) +# endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R init_fixed_SSP' + END IF + + SSP%Seg%r( 1:SSP%Nr ) = ihop_ranges( 1:SSP%Nr ) + ! Modify from [m] to [km] + SSP%Seg%r = 1000.0 * SSP%Seg%r + + ! ONLY ALLOCATE cmat and czmat, to be filled per ihop run + ALLOCATE( SSP%cMat( SSP%Nz, SSP%Nr ), & + SSP%czMat( SSP%Nz-1, SSP%Nr ), & + STAT = iallocstat ) + IF ( iallocstat /= 0 ) THEN +# ifdef IHOP_WRITE_OUT + WRITE(msgBuf,'(2A)') 'SSPMOD init_fixed_SSP: ', & + 'Insufficient memory to store SSP%cmat, SSP%czmat' + CALL PRINT_ERROR( msgBuf,myThid ) +# endif /* IHOP_WRITE_OUT */ + STOP 'ABNORMAL END: S/R init_fixed_SSP' + END IF + ! Initiate to nonsense + SSP%cMat = -99.0 _d 0 + SSP%czMat = -99.0 _d 0 + + !================================================== + ! IDW Interpolate: COMPARING with LAT LONs (xC, yC) + !================================================== + ! Sum IDW weights + DO ii = 1, SSP%Nr + ihop_sumweights(ii,:) = sum(ihop_idw_weights(ii,:)) + END DO + + ! Adapt IDW interpolation by bathymetry + DO bj=myByLo(myThid),myByHi(myThid) + DO bi=myBxLo(myThid),myBxHi(myThid) + DO j=1,sNy + DO i=1,sNx + DO ii=1, SSP%Nr + skip_range = .FALSE. + + DO jj=1,IHOP_npts_idw + IF (ABS(xC(i, j, bi, bj) - ihop_xc(ii, jj)) .LE. tolerance .AND. & + ABS(yC(i, j, bi, bj) - ihop_yc(ii, jj)) .LE. tolerance) THEN + DO k=1,Nr + ! No IDW interpolation on xc, yc centered ranges + IF (nii(ii) .EQ. 1 .AND. k .GT. njj(ii)) THEN + skip_range = .TRUE. + END IF + + IF (.NOT. skip_range) THEN + IF (hFacC(i, j, k, bi, bj) .EQ. 0.0) THEN + ihop_sumweights(ii, k) = & + ihop_sumweights(ii, k) - ihop_idw_weights(ii, jj) + + ! No interpolation on xc, yc centered ranges + IF (ihop_idw_weights(ii, jj) .EQ. 0.0) THEN + ihop_sumweights(ii, k:Nr) = 0.0 + nii(ii) = 1 + njj(ii) = k + END IF + END IF + + ! Set TINY and negative values to 0.0 + IF (ihop_sumweights(ii, k) .LT. 1D-13) ihop_sumweights(ii, k) = 0.0 + END IF + END DO !k + END IF + END DO !jj + END DO !ii + END DO !i + END DO !j + END DO !bi + END DO !bj + +END !SUBROUTINE init_fixed_ssp + END MODULE ssp_mod From ee9854a74764196cfbbf4d7d1ae1afcf6a3a2705 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 14:58:30 -0500 Subject: [PATCH 10/13] rm trailing spaces --- mitgcm_code/DXC_MACROS.h | 8 ++++---- mitgcm_code/DXF_MACROS.h | 8 ++++---- mitgcm_code/DXG_MACROS.h | 8 ++++---- mitgcm_code/DXV_MACROS.h | 8 ++++---- mitgcm_code/DYC_MACROS.h | 8 ++++---- mitgcm_code/DYF_MACROS.h | 8 ++++---- mitgcm_code/DYG_MACROS.h | 8 ++++---- mitgcm_code/DYU_MACROS.h | 8 ++++---- mitgcm_code/FCORI_MACROS.h | 8 ++++---- mitgcm_code/HFACC_MACROS.h | 8 ++++---- mitgcm_code/HFACS_MACROS.h | 8 ++++---- mitgcm_code/HFACW_MACROS.h | 8 ++++---- mitgcm_code/IHOP_SIZE.h | 14 +++++++------- mitgcm_code/MASKS_MACROS.h | 8 ++++---- mitgcm_code/MASKW_MACROS.h | 8 ++++---- mitgcm_code/RAS_MACROS.h | 8 ++++---- mitgcm_code/RAW_MACROS.h | 8 ++++---- mitgcm_code/RA_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DXC_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DXF_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DXG_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DXV_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DYC_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DYF_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DYG_MACROS.h | 8 ++++---- mitgcm_code/RECIP_DYU_MACROS.h | 8 ++++---- mitgcm_code/RECIP_HFACC_MACROS.h | 8 ++++---- mitgcm_code/RECIP_HFACS_MACROS.h | 8 ++++---- mitgcm_code/RECIP_HFACW_MACROS.h | 8 ++++---- mitgcm_code/TANPHIATU_MACROS.h | 8 ++++---- mitgcm_code/TANPHIATV_MACROS.h | 8 ++++---- mitgcm_code/XC_MACROS.h | 8 ++++---- mitgcm_code/YC_MACROS.h | 8 ++++---- mitgcm_code/forward_step.F | 2 +- mitgcm_code/the_main_loop.F | 2 +- mitgcm_input/data.ihop | 4 ++-- mitgcm_input/data.pkg_ad | 2 +- 37 files changed, 140 insertions(+), 140 deletions(-) diff --git a/mitgcm_code/DXC_MACROS.h b/mitgcm_code/DXC_MACROS.h index 43acd2f..5822e83 100644 --- a/mitgcm_code/DXC_MACROS.h +++ b/mitgcm_code/DXC_MACROS.h @@ -5,11 +5,11 @@ !C include DXC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DXC_MACROS.h +!C | DXC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DXF_MACROS.h b/mitgcm_code/DXF_MACROS.h index 9feaf21..e40ffa3 100644 --- a/mitgcm_code/DXF_MACROS.h +++ b/mitgcm_code/DXF_MACROS.h @@ -5,11 +5,11 @@ !C include DXF_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DXF_MACROS.h +!C | DXF_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DXG_MACROS.h b/mitgcm_code/DXG_MACROS.h index 6d138cf..f282e31 100644 --- a/mitgcm_code/DXG_MACROS.h +++ b/mitgcm_code/DXG_MACROS.h @@ -5,11 +5,11 @@ !C include DXG_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DXG_MACROS.h +!C | DXG_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DXV_MACROS.h b/mitgcm_code/DXV_MACROS.h index f10affc..c866676 100644 --- a/mitgcm_code/DXV_MACROS.h +++ b/mitgcm_code/DXV_MACROS.h @@ -5,11 +5,11 @@ !C include DXV_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DXV_MACROS.h +!C | DXV_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DYC_MACROS.h b/mitgcm_code/DYC_MACROS.h index c27d065..caf59d2 100644 --- a/mitgcm_code/DYC_MACROS.h +++ b/mitgcm_code/DYC_MACROS.h @@ -5,11 +5,11 @@ !C include DYC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DYC_MACROS.h +!C | DYC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DYF_MACROS.h b/mitgcm_code/DYF_MACROS.h index 320d443..d8539b7 100644 --- a/mitgcm_code/DYF_MACROS.h +++ b/mitgcm_code/DYF_MACROS.h @@ -5,11 +5,11 @@ !C include DYF_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DYF_MACROS.h +!C | DYF_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DYG_MACROS.h b/mitgcm_code/DYG_MACROS.h index c26b6ac..ef31a01 100644 --- a/mitgcm_code/DYG_MACROS.h +++ b/mitgcm_code/DYG_MACROS.h @@ -5,11 +5,11 @@ !C include DYG_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DYG_MACROS.h +!C | DYG_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/DYU_MACROS.h b/mitgcm_code/DYU_MACROS.h index 15f0d25..fa10da6 100644 --- a/mitgcm_code/DYU_MACROS.h +++ b/mitgcm_code/DYU_MACROS.h @@ -5,11 +5,11 @@ !C include DYU_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | DYU_MACROS.h +!C | DYU_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/FCORI_MACROS.h b/mitgcm_code/FCORI_MACROS.h index 8e7f3e7..73786e7 100644 --- a/mitgcm_code/FCORI_MACROS.h +++ b/mitgcm_code/FCORI_MACROS.h @@ -5,11 +5,11 @@ !C include FCORI_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | FCORI_MACROS.h +!C | FCORI_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/HFACC_MACROS.h b/mitgcm_code/HFACC_MACROS.h index d8f8f36..7a36bc0 100644 --- a/mitgcm_code/HFACC_MACROS.h +++ b/mitgcm_code/HFACC_MACROS.h @@ -5,11 +5,11 @@ !C include HFACC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | HFACC_MACROS.h +!C | HFACC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/HFACS_MACROS.h b/mitgcm_code/HFACS_MACROS.h index 090985e..4da8474 100644 --- a/mitgcm_code/HFACS_MACROS.h +++ b/mitgcm_code/HFACS_MACROS.h @@ -5,11 +5,11 @@ !C include HFACS_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | HFACS_MACROS.h +!C | HFACS_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/HFACW_MACROS.h b/mitgcm_code/HFACW_MACROS.h index ddffd15..c1b2cea 100644 --- a/mitgcm_code/HFACW_MACROS.h +++ b/mitgcm_code/HFACW_MACROS.h @@ -5,11 +5,11 @@ !C include HFACW_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | HFACW_MACROS.h +!C | HFACW_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/IHOP_SIZE.h b/mitgcm_code/IHOP_SIZE.h index 8d140a8..7a8a629 100644 --- a/mitgcm_code/IHOP_SIZE.h +++ b/mitgcm_code/IHOP_SIZE.h @@ -18,7 +18,7 @@ INTEGER nts #ifdef IHOP_MULTIPLE_TIMES PARAMETER ( nts=1080 ) -#else +#else PARAMETER ( nts=1 ) #endif @@ -32,23 +32,23 @@ INTEGER nsd #ifdef IHOP_MULTIPLE_SOURCES PARAMETER ( nsd=10 ) -#else +#else PARAMETER ( nsd=1 ) #endif - + ! Number of Receivers: ! ================================ INTEGER nrd INTEGER nrr #ifdef IHOP_MULTIPLE_RECEIVER_DEPTHS PARAMETER ( nrd=30 ) -#else +#else PARAMETER ( nrd=1 ) #endif #ifdef IHOP_MULTIPLE_RECEIVER_RANGES PARAMETER ( nrr=30 ) -#else +#else PARAMETER ( nrr=1 ) #endif @@ -56,14 +56,14 @@ ! ================================ INTEGER IHOP_MAX_NC_SIZE PARAMETER ( IHOP_MAX_NC_SIZE = 15 ) -! INTEGER IHOP_NPTS_RANGE +! INTEGER IHOP_NPTS_RANGE ! PARAMETER( IHOP_NPTS_RANGE = 6 ) ! INTEGER IHOP_IDW_NPTS ! PARAMETER( IHOP_IDW_NPTS = 4 ) -! Cost function sizes +! Cost function sizes ! ================================ ! NFILESMAX_ihop :: maximum number of input files ! NOBSMAX_ihop :: maximum number of observations per file per tile diff --git a/mitgcm_code/MASKS_MACROS.h b/mitgcm_code/MASKS_MACROS.h index c52a3b4..5799e7a 100644 --- a/mitgcm_code/MASKS_MACROS.h +++ b/mitgcm_code/MASKS_MACROS.h @@ -5,11 +5,11 @@ !C include MASKS_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | MASKS_MACROS.h +!C | MASKS_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/MASKW_MACROS.h b/mitgcm_code/MASKW_MACROS.h index d5ee261..a2e532e 100644 --- a/mitgcm_code/MASKW_MACROS.h +++ b/mitgcm_code/MASKW_MACROS.h @@ -5,11 +5,11 @@ !C include MASKW_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | MASKW_MACROS.h +!C | MASKW_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RAS_MACROS.h b/mitgcm_code/RAS_MACROS.h index dd68b45..1c9ad02 100644 --- a/mitgcm_code/RAS_MACROS.h +++ b/mitgcm_code/RAS_MACROS.h @@ -5,11 +5,11 @@ !C include RAS_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RAS_MACROS.h +!C | RAS_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RAW_MACROS.h b/mitgcm_code/RAW_MACROS.h index b5afe0f..9067165 100644 --- a/mitgcm_code/RAW_MACROS.h +++ b/mitgcm_code/RAW_MACROS.h @@ -5,11 +5,11 @@ !C include RAW_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RAW_MACROS.h +!C | RAW_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RA_MACROS.h b/mitgcm_code/RA_MACROS.h index 6f5f77d..7d8c698 100644 --- a/mitgcm_code/RA_MACROS.h +++ b/mitgcm_code/RA_MACROS.h @@ -5,11 +5,11 @@ !C include RA_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RA_MACROS.h +!C | RA_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DXC_MACROS.h b/mitgcm_code/RECIP_DXC_MACROS.h index 9cccb3d..1f9224b 100644 --- a/mitgcm_code/RECIP_DXC_MACROS.h +++ b/mitgcm_code/RECIP_DXC_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DXC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DXC_MACROS.h +!C | RECIP_DXC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DXF_MACROS.h b/mitgcm_code/RECIP_DXF_MACROS.h index 8a81808..eb031b7 100644 --- a/mitgcm_code/RECIP_DXF_MACROS.h +++ b/mitgcm_code/RECIP_DXF_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DXF_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DXF_MACROS.h +!C | RECIP_DXF_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DXG_MACROS.h b/mitgcm_code/RECIP_DXG_MACROS.h index 7abe8e6..de0d084 100644 --- a/mitgcm_code/RECIP_DXG_MACROS.h +++ b/mitgcm_code/RECIP_DXG_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DXG_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DXG_MACROS.h +!C | RECIP_DXG_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DXV_MACROS.h b/mitgcm_code/RECIP_DXV_MACROS.h index 5832ef2..b0d0157 100644 --- a/mitgcm_code/RECIP_DXV_MACROS.h +++ b/mitgcm_code/RECIP_DXV_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DXV_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DXV_MACROS.h +!C | RECIP_DXV_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DYC_MACROS.h b/mitgcm_code/RECIP_DYC_MACROS.h index dce0ffe..f2b5aeb 100644 --- a/mitgcm_code/RECIP_DYC_MACROS.h +++ b/mitgcm_code/RECIP_DYC_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DYC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DYC_MACROS.h +!C | RECIP_DYC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DYF_MACROS.h b/mitgcm_code/RECIP_DYF_MACROS.h index 16659c4..8b01f5f 100644 --- a/mitgcm_code/RECIP_DYF_MACROS.h +++ b/mitgcm_code/RECIP_DYF_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DYF_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DYF_MACROS.h +!C | RECIP_DYF_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DYG_MACROS.h b/mitgcm_code/RECIP_DYG_MACROS.h index c85353b..93c394c 100644 --- a/mitgcm_code/RECIP_DYG_MACROS.h +++ b/mitgcm_code/RECIP_DYG_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DYG_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DYG_MACROS.h +!C | RECIP_DYG_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_DYU_MACROS.h b/mitgcm_code/RECIP_DYU_MACROS.h index ce37ce4..740b5c2 100644 --- a/mitgcm_code/RECIP_DYU_MACROS.h +++ b/mitgcm_code/RECIP_DYU_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_DYU_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_DYU_MACROS.h +!C | RECIP_DYU_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_HFACC_MACROS.h b/mitgcm_code/RECIP_HFACC_MACROS.h index 3248179..e4af83c 100644 --- a/mitgcm_code/RECIP_HFACC_MACROS.h +++ b/mitgcm_code/RECIP_HFACC_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_HFACC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_HFACC_MACROS.h +!C | RECIP_HFACC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_HFACS_MACROS.h b/mitgcm_code/RECIP_HFACS_MACROS.h index 37d67d3..c72008c 100644 --- a/mitgcm_code/RECIP_HFACS_MACROS.h +++ b/mitgcm_code/RECIP_HFACS_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_HFACS_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_HFACS_MACROS.h +!C | RECIP_HFACS_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/RECIP_HFACW_MACROS.h b/mitgcm_code/RECIP_HFACW_MACROS.h index caadfd6..e118e2d 100644 --- a/mitgcm_code/RECIP_HFACW_MACROS.h +++ b/mitgcm_code/RECIP_HFACW_MACROS.h @@ -5,11 +5,11 @@ !C include RECIP_HFACW_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | RECIP_HFACW_MACROS.h +!C | RECIP_HFACW_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/TANPHIATU_MACROS.h b/mitgcm_code/TANPHIATU_MACROS.h index 582fe59..3ceef3a 100644 --- a/mitgcm_code/TANPHIATU_MACROS.h +++ b/mitgcm_code/TANPHIATU_MACROS.h @@ -5,11 +5,11 @@ !C include TANPHIATU_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | TANPHIATU_MACROS.h +!C | TANPHIATU_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/TANPHIATV_MACROS.h b/mitgcm_code/TANPHIATV_MACROS.h index b0c0297..71e6581 100644 --- a/mitgcm_code/TANPHIATV_MACROS.h +++ b/mitgcm_code/TANPHIATV_MACROS.h @@ -5,11 +5,11 @@ !C include TANPHIATV_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | TANPHIATV_MACROS.h +!C | TANPHIATV_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/XC_MACROS.h b/mitgcm_code/XC_MACROS.h index 349afae..3e4044b 100644 --- a/mitgcm_code/XC_MACROS.h +++ b/mitgcm_code/XC_MACROS.h @@ -5,11 +5,11 @@ !C include XC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | XC_MACROS.h +!C | XC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/YC_MACROS.h b/mitgcm_code/YC_MACROS.h index e024e06..4dc0c33 100644 --- a/mitgcm_code/YC_MACROS.h +++ b/mitgcm_code/YC_MACROS.h @@ -5,11 +5,11 @@ !C include YC_MACROS.h !C !DESCRIPTION: \bv !C *==========================================================* -!C | YC_MACROS.h +!C | YC_MACROS.h !C *==========================================================* -!C | These macros are used to reduce memory requirement and/or -!C | memory references when variables are fixed along a given -!C | axis or axes. +!C | These macros are used to reduce memory requirement and/or +!C | memory references when variables are fixed along a given +!C | axis or axes. !C *==========================================================* !C \ev !CEOP diff --git a/mitgcm_code/forward_step.F b/mitgcm_code/forward_step.F index 5122fcb..736008b 100644 --- a/mitgcm_code/forward_step.F +++ b/mitgcm_code/forward_step.F @@ -207,7 +207,7 @@ SUBROUTINE FORWARD_STEP( iloop, myTime, myIter, myThid ) C | C |-- GCHEM_FORCING_SEP C | -C ?IHOP HERE FOR NOW? +C ?IHOP HERE FOR NOW? C | C |-- DO_FIELDS_BLOCKING_EXCHANGES C | diff --git a/mitgcm_code/the_main_loop.F b/mitgcm_code/the_main_loop.F index 8c554c5..18a22b6 100644 --- a/mitgcm_code/the_main_loop.F +++ b/mitgcm_code/the_main_loop.F @@ -698,7 +698,7 @@ SUBROUTINE THE_MAIN_LOOP( myTime, myIter, myThid ) #ifdef ALLOW_DEBUG IF (debugMode) CALL DEBUG_CALL('ihop_cost_inloop',myThid) #endif -c-- Accumulate in-situ acoutsic travel times. +c-- Accumulate in-situ acoutsic travel times. #ifdef ALLOW_AUTODIFF C-- Reset the model iteration counter and the model time. myIter = nIter0 + (iloop-1) diff --git a/mitgcm_input/data.ihop b/mitgcm_input/data.ihop index 0c37ca2..740552c 100644 --- a/mitgcm_input/data.ihop +++ b/mitgcm_input/data.ihop @@ -1,7 +1,7 @@ # *********************** # IHOP package parameters # *********************** - &IHOP_PARM01 + &IHOP_PARM01 IHOP_fileroot='baroA', IHOP_title='baroclinic_gyre+ihop', & @@ -9,7 +9,7 @@ &IHOP_PARM02 IHOP_freq=550.0, IHOP_topopt='QVF', - + IHOP_botopt='A*', IHOP_bcsound=1650.0, IHOP_brho=1.80, diff --git a/mitgcm_input/data.pkg_ad b/mitgcm_input/data.pkg_ad index 8d4c195..c09e6c1 100644 --- a/mitgcm_input/data.pkg_ad +++ b/mitgcm_input/data.pkg_ad @@ -4,7 +4,7 @@ useIHOP=.true., useDiagnostics=.true., useCal=.true., -# AD packages +# AD packages useGrdChk=.true., useProfiles=.true., useEcco=.true., From 2885b7160c0737a63fc9183f74d8c8404aa08933 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 15:04:06 -0500 Subject: [PATCH 11/13] rename init modules --- src/ihop_init_fixed.F | 4 ++-- src/{ihop_init_fixed_env.F90 => ihop_init_mod.F90} | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) rename src/{ihop_init_fixed_env.F90 => ihop_init_mod.F90} (99%) diff --git a/src/ihop_init_fixed.F b/src/ihop_init_fixed.F index 3e47e5b..038662b 100644 --- a/src/ihop_init_fixed.F +++ b/src/ihop_init_fixed.F @@ -13,7 +13,7 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) C !USES: - use init_mod, only: ihop_init_fixed_env + use ihop_init_mod, only: init_fixed_env IMPLICIT NONE C ==================== Global Variables =========================== #include "EEPARAMS.h" @@ -140,7 +140,7 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) ihop_sumweights(i,k) = -1.0 END DO END DO - CALL ihop_init_fixed_env( myThid ) + CALL init_fixed_env( myThid ) C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| #ifdef ALLOW_MNC diff --git a/src/ihop_init_fixed_env.F90 b/src/ihop_init_mod.F90 similarity index 99% rename from src/ihop_init_fixed_env.F90 rename to src/ihop_init_mod.F90 index b3749c9..2261223 100644 --- a/src/ihop_init_fixed_env.F90 +++ b/src/ihop_init_mod.F90 @@ -1,13 +1,13 @@ #include "IHOP_OPTIONS.h" -MODULE init_mod +MODULE ihop_init_mod IMPLICIT NONE PRIVATE -public ihop_init_fixed_env +public init_fixed_env CONTAINS - SUBROUTINE IHOP_INIT_FIXED_ENV ( myThid ) + SUBROUTINE INIT_FIXED_ENV ( myThid ) ! Initiate fixed variable for ihop time series. Note: NO IHOP_THREED here ! =========================================================================== @@ -674,4 +674,4 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) RETURN END !SUBROUTINE ReadRunType !**********************************************************************! -END MODULE init_mod +END MODULE ihop_init_mod From 70bc419f6da28e254a170a3dd1b6152a77769438 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 15:13:40 -0500 Subject: [PATCH 12/13] ad flow and list updates --- src/ihop_ad.flow | 6 +++--- src/ihop_ad_diff.list | 3 ++- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/ihop_ad.flow b/src/ihop_ad.flow index 8afdabb..3f549d8 100644 --- a/src/ihop_ad.flow +++ b/src/ihop_ad.flow @@ -13,7 +13,7 @@ ! *==========================================================* ! | SUBROUTINE WRITEARRIVALSACSII is passive | ! | SUBROUTINE WRITEARRVIALSBINARY is passive | -! | SUBROUTINE OPENOUTPUTFILS is passive | +! | SUBROUTINE OPENOUTPUTFILES is passive | ! *==========================================================* !$TAF SUBROUTINE arr_mod::writearrivalsascii INPUT = 1, 2, 3, 4 !$TAF SUBROUTINE arr_mod::writearrivalsascii OUTPUT = @@ -21,8 +21,8 @@ !$TAF SUBROUTINE arr_mod::writearrivalsbinary INPUT = 1, 2, 3, 4 !$TAF SUBROUTINE arr_mod::writearrivalsbinary OUTPUT = -!$TAF SUBROUTINE initenvihop::OpenOutputFiles INPUT = 1, 2, 3, 4 -!$TAF SUBROUTINE initenvihop::OpenOutputFiles OUTPUT = +!$TAF SUBROUTINE ihop_init_diag::openOutputFiles INPUT = 1, 2, 3, 4 +!$TAF SUBROUTINE ihop_init_diag::openOutputFiles OUTPUT = ! *==========================================================* ! | SUBROUTINE READSSP is passive | diff --git a/src/ihop_ad_diff.list b/src/ihop_ad_diff.list index ba8983c..e29d9bf 100644 --- a/src/ihop_ad_diff.list +++ b/src/ihop_ad_diff.list @@ -14,12 +14,13 @@ atten_mod.f90 bdry_mod.f90 beampattern.f90 bellhop.f90 +ihop_init_diag.f90 +ihop_init_mod.f90 ihop_mod.f90 influence.f90 monotonic_mod.f90 pchip_mod.f90 poly_mod.f90 -initenvihop.f90 refcoef.f90 sort_mod.f90 splinec_mod.f90 From ea1f5a5fbc37aa32701504def801782cf6a8b001 Mon Sep 17 00:00:00 2001 From: Ivana Escobar Date: Tue, 17 Sep 2024 15:16:35 -0500 Subject: [PATCH 13/13] rm trailing spaces --- inc/IHOP.h | 20 +- inc/IHOP_COST.h | 16 +- inc/IHOP_SIZE.h | 14 +- src/active_file_control_ihop_cost.F | 16 +- src/active_file_ihop_cost.F | 24 +-- src/active_file_ihop_cost_ad.F | 2 +- src/angle_mod.F90 | 24 +-- src/arr_mod.F90 | 18 +- src/atten_mod.F90 | 12 +- src/bdry_mod.F90 | 78 ++++---- src/beampattern.F90 | 2 +- src/bellhop.F90 | 292 ++++++++++++++-------------- src/chen_millero.F | 20 +- src/cost_ihop.F | 20 +- src/ihop_ad.flow | 14 +- src/ihop_cost_init_equifiles.F | 8 +- src/ihop_cost_init_fixed.F | 38 ++-- src/ihop_cost_inloop.F | 12 +- src/ihop_cost_modval.F | 12 +- src/ihop_cost_read_obs.F | 12 +- src/ihop_ini_io.F | 8 +- src/ihop_init_diag.F90 | 58 +++--- src/ihop_init_fixed.F | 4 +- src/ihop_init_mod.F90 | 104 +++++----- src/ihop_mod.F90 | 2 +- src/ihop_readparms.F | 24 +-- src/ihop_sound_speed.F | 6 +- src/influence.F90 | 102 +++++----- src/monotonic_mod.F90 | 10 +- src/pchip_mod.F90 | 4 +- src/refcoef.F90 | 16 +- src/sort_mod.F90 | 2 +- src/splinec_mod.F90 | 14 +- src/srpos_mod.F90 | 68 +++---- src/ssp_mod.F90 | 148 +++++++------- src/step.F90 | 28 +-- src/writeray.F90 | 10 +- 37 files changed, 631 insertions(+), 631 deletions(-) diff --git a/inc/IHOP.h b/inc/IHOP.h index 9395efa..9aa8a5d 100644 --- a/inc/IHOP.h +++ b/inc/IHOP.h @@ -21,7 +21,7 @@ ! IHOP parameters ! =============== !-- COMMON /IHOP_PARAMS_L/ IHOP logical-type parameters: -! writeDelay :: true if delay is a desired output +! writeDelay :: true if delay is a desired output ! useSSPFile :: true if *.ssp is used instead MITgcm SSP LOGICAL writeDelay @@ -32,7 +32,7 @@ !-- COMMON /IHOP_PARAMS_C/ IHOP Character-type parameters: ! IHOP_fileroot :: File name for reading in an environment -! IHOP_title :: Title name for writing into output files +! IHOP_title :: Title name for writing into output files ! IHOP_interpfile :: File name for reading NetCDF inputs ! IHOP_topopt :: SSP interpolation, top boundary type ! IHOP_botopt :: bottom boundary type @@ -77,10 +77,10 @@ ! IHOP_dumpfreq :: frequency of output dump to run directory ! IHOP_freq :: frequency (Hz) ! IHOP_depth :: depth of bottom (m) -! IHOP_bcsound :: bottom sound speed (m/s) -! IHOP_bcsoundshear :: shear bottom sound speed (m/s) -! IHOP_bcsoundI :: IMAG bottom sound speed (m/s) -! IHOP_bcsoundshearI :: IMAG shear bottom sound speed (m/s) +! IHOP_bcsound :: bottom sound speed (m/s) +! IHOP_bcsoundshear :: shear bottom sound speed (m/s) +! IHOP_bcsoundI :: IMAG bottom sound speed (m/s) +! IHOP_bcsoundshearI :: IMAG shear bottom sound speed (m/s) ! IHOP_brho :: bottom density (kg/m^3) ! IHOP_sd :: source depth (m) ! IHOP_rd :: receiver depth (m) @@ -92,9 +92,9 @@ _RL IHOP_freq _RL IHOP_depth _RL IHOP_bcsound - _RL IHOP_bcsoundshear + _RL IHOP_bcsoundshear _RL IHOP_bcsoundI - _RL IHOP_bcsoundshearI + _RL IHOP_bcsoundshearI _RL IHOP_brho _RL IHOP_sd (nsd) _RL IHOP_rd (nrd) @@ -105,7 +105,7 @@ _RS ihop_xc ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) _RS ihop_yc ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) _RL ihop_ranges ( IHOP_MAX_NC_SIZE ) - _RL ihop_sumweights ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) + _RL ihop_sumweights ( IHOP_MAX_NC_SIZE, IHOP_MAX_NC_SIZE ) COMMON /IHOP_PARAMS_R/ & & IHOP_dumpfreq, & @@ -119,7 +119,7 @@ !C IHOP 3-dim. fields _RL ihop_ssp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr,nSx,nSy) COMMON /IHOP_STATE_3D/ & - & ihop_ssp + & ihop_ssp #endif /* IHOP_3D_STATE */ #ifdef IHOP_2D_STATE diff --git a/inc/IHOP_COST.h b/inc/IHOP_COST.h index c710a6c..1a5f359 100644 --- a/inc/IHOP_COST.h +++ b/inc/IHOP_COST.h @@ -8,7 +8,7 @@ COMMON /ihop_cost_l/ ihopDoNcOutput -! IHOP cost integer parameters +! IHOP cost integer parameters ! ObsNo* :: No. of observations in a single ihop obs file, iOBS ! ihopObs_ind_glob* :: MITgcm global index of each obs datum @@ -28,25 +28,25 @@ COMMON /ihop_cost_i/ & & ObsNo, ObsNo_tiled, & & ihopObs_ind_glob, ihopObs_ind_glob_tiled, & - & fidfwd_obs, fidadj_obs, fidglobal, fidadglobal, + & fidfwd_obs, fidadj_obs, fidglobal, fidadglobal, & fiddata_obs, & & ihopObs_i_tiled, ihopObs_j_tiled, ihopObs_k_tiled, & & ihopObs_sample1_ind - + ! IHOP buffers _RL ihop_data_buff(1000) _RL ihop_uncert_buff(1000) INTEGER ihop_minind_buff INTEGER ihop_maxind_buff INTEGER ihop_curfile_buff - + COMMON /IHOP_BUFF_R/ ihop_data_buff, ihop_uncert_buff COMMON /IHOP_BUFF_I/ & & ihop_minind_buff, ihop_maxind_buff, ihop_curfile_buff - + ! IHOP cost real parameters ! objf_ihop :: ihop travel times -! num_ihop :: number of observations +! num_ihop :: number of observations ! mult_ihop :: multiplier applied to all cost terms ! ihopObs_time :: obs. start time @@ -58,7 +58,7 @@ _RL ihopObs_lat(NFILESMAX_IHOP,NOBSMAX_IHOP,nsx,nsy) _RL ihopObs_depth(NFILESMAX_IHOP,NOBSMAX_IHOP,nsx,nsy) _RL ihopObs_uncert(NFILESMAX_IHOP,NOBSMAX_IHOP,nsx,nsy) - _RL ihopObs_modmask + _RL ihopObs_modmask _RL ihopObs_modmask_tiled(nsx,nsy) COMMON /IHOP_COST_R/ & & objf_ihop, & @@ -70,7 +70,7 @@ ! IHOP cost filenames ! ihopObsDir :: directory where ihop observations are found -! ihopObsFile :: file name for ihop observations +! ihopObsFile :: file name for ihop observations CHARACTER*(MAX_LEN_FNAM) ihopObsDir CHARACTER*(MAX_LEN_FNAM) ihopObsFiles(NFILESMAX_IHOP) diff --git a/inc/IHOP_SIZE.h b/inc/IHOP_SIZE.h index 1d4086d..1f4165b 100644 --- a/inc/IHOP_SIZE.h +++ b/inc/IHOP_SIZE.h @@ -18,7 +18,7 @@ INTEGER nts #ifdef IHOP_MULTIPLE_TIMES PARAMETER ( nts=10 ) -#else +#else PARAMETER ( nts=1 ) #endif @@ -32,23 +32,23 @@ INTEGER nsd #ifdef IHOP_MULTIPLE_SOURCES PARAMETER ( nsd=10 ) -#else +#else PARAMETER ( nsd=1 ) #endif - + ! Number of Receivers: ! ================================ INTEGER nrd INTEGER nrr #ifdef IHOP_MULTIPLE_RECEIVER_DEPTHS PARAMETER ( nrd=30 ) -#else +#else PARAMETER ( nrd=1 ) #endif #ifdef IHOP_MULTIPLE_RECEIVER_RANGES PARAMETER ( nrr=30 ) -#else +#else PARAMETER ( nrr=1 ) #endif @@ -56,14 +56,14 @@ ! ================================ INTEGER IHOP_MAX_NC_SIZE PARAMETER ( IHOP_MAX_NC_SIZE = 10 ) -! INTEGER IHOP_NPTS_RANGE +! INTEGER IHOP_NPTS_RANGE ! PARAMETER( IHOP_NPTS_RANGE = 6 ) ! INTEGER IHOP_IDW_NPTS ! PARAMETER( IHOP_IDW_NPTS = 4 ) -! Cost function sizes +! Cost function sizes ! ================================ ! NFILESMAX_ihop :: maximum number of input files ! NOBSMAX_ihop :: maximum number of observations per file per tile diff --git a/src/active_file_control_ihop_cost.F b/src/active_file_control_ihop_cost.F index 1a6ccb9..3305360 100644 --- a/src/active_file_control_ihop_cost.F +++ b/src/active_file_control_ihop_cost.F @@ -21,11 +21,11 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE_RL( I bj, I myThid ) -C !DESCRIPTION: +C !DESCRIPTION: C ================================================================== C | SUBROUTINE ACTIVE_READ_IHOP_TILE_RL C | Read an active record from an IHOP .equi. tiled file -C | (can be netcdf or binary) +C | (can be netcdf or binary) C ================================================================== C !USES: @@ -70,7 +70,7 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE_RL( _BEGIN_MASTER( myThid ) if (ihopDoNcOutput) then - + vec_start=irec vec_count=1 @@ -212,11 +212,11 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE_RL( I bj, I myThid ) -C !DESCRIPTION: +C !DESCRIPTION: C ========================================================== C | SUBROUTINE ACTIVE_WRITE_IHOP_TILE_RL C | Write an active record to an ihop .equi. tiled file -C | (can be netcdf or binary) +C | (can be netcdf or binary) C ========================================================== C !USES: @@ -359,7 +359,7 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB_RL( I myOptimIter, I myThid ) -C !DESCRIPTION: +C !DESCRIPTION: C ================================================================== C | SUBROUTINE ACTIVE_READ_IHOP_GLOB_RL C | Read an active record from an IHOP .equi. global file @@ -405,7 +405,7 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB_RL( if (theSimulationMode .eq. FORWARD_SIMULATION) then _BEGIN_MASTER( myThid ) - + vec_start=irecglob vec_count=1 @@ -488,7 +488,7 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB_RL( I myOptimIter, I myThid ) -C !DESCRIPTION: +C !DESCRIPTION: C ========================================================== C | SUBROUTINE ACTIVE_WRITE_IHOP_GLOB_RL C | Write an active record to an ihop .equi. global file diff --git a/src/active_file_ihop_cost.F b/src/active_file_ihop_cost.F index 3648be7..869d228 100644 --- a/src/active_file_ihop_cost.F +++ b/src/active_file_ihop_cost.F @@ -21,11 +21,11 @@ SUBROUTINE ACTIVE_READ_IHOP_TILE( I myThid, I dummy ) -C !DESCRIPTION: +C !DESCRIPTION: C ================================================================== C | SUBROUTINE ACTIVE_READ_IHOP_TILE C | Read an active record from an ihop cost .equi. tiled file -C | (can be netcdf or binary) +C | (can be netcdf or binary) C ================================================================== C !USES: @@ -84,10 +84,10 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE( I myThid, I dummy ) -C !DESCRIPTION: +C !DESCRIPTION: C ================================================================== C | SUBROUTINE ACTIVE_WRITE_IHOP_TILE -C | Write to a file the model-equivalent value to an +C | Write to a file the model-equivalent value to an c | observation sample during the model run C ================================================================== @@ -120,7 +120,7 @@ SUBROUTINE ACTIVE_WRITE_IHOP_TILE( CALL active_write_ihop_tile_rl( fidfwd_obs(active_num_file,bi,bj), & active_num_file, - & active_var, + & active_var, & irec, ihopObs_ind_glob_tiled(active_num_file,irec,bi,bj), & FORWARD_SIMULATION, myOptimIter, bi, bj, myThid) @@ -144,11 +144,11 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB( I myThid, I dummy ) -C !DESCRIPTION: +C !DESCRIPTION: C ================================================================== C | SUBROUTINE ACTIVE_READ_IHOP_GLOB C | Read an active record from an ihop cost .equi. tiled file -C | (can be netcdf or binary) +C | (can be netcdf or binary) C ================================================================== C !USES: @@ -181,7 +181,7 @@ SUBROUTINE ACTIVE_READ_IHOP_GLOB( #if (defined ALLOW_IHOP) && (defined ALLOW_COST) - CALL active_read_ihop_glob_rl( + CALL active_read_ihop_glob_rl( & fidglobal(active_num_file), & active_num_file, & active_var, lAdInit, @@ -206,10 +206,10 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB( I myThid, I dummy ) -C !DESCRIPTION: +C !DESCRIPTION: C ================================================================== C | SUBROUTINE ACTIVE_WRITE_IHOP_GLOB -C | Write to a file the model-equivalent value to an +C | Write to a file the model-equivalent value to an c | observation sample during the model run C ================================================================== @@ -240,10 +240,10 @@ SUBROUTINE ACTIVE_WRITE_IHOP_GLOB( #if (defined ALLOW_IHOP) && (defined ALLOW_COST) - CALL active_write_ihop_glob_rl( + CALL active_write_ihop_glob_rl( & fidglobal(active_num_file), & active_num_file, - & active_var, + & active_var, & irec, ihopObs_ind_glob(active_num_file,irec), & FORWARD_SIMULATION, myOptimIter, myThid) diff --git a/src/active_file_ihop_cost_ad.F b/src/active_file_ihop_cost_ad.F index f2c7f49..3370f34 100644 --- a/src/active_file_ihop_cost_ad.F +++ b/src/active_file_ihop_cost_ad.F @@ -115,7 +115,7 @@ SUBROUTINE ADACTIVE_WRITE_IHOP_TILE( CALL active_write_ihop_tile_rl( fidadj_obs(active_num_file,bi,bj), & active_num_file, - & adactive_var, + & adactive_var, & irec, ihopObs_ind_glob_tiled(active_num_file,irec,bi,bj), & REVERSE_SIMULATION, myIter, bi, bj, myThid) diff --git a/src/angle_mod.F90 b/src/angle_mod.F90 index 432ef6b..f7f6b70 100644 --- a/src/angle_mod.F90 +++ b/src/angle_mod.F90 @@ -31,7 +31,7 @@ MODULE angle_mod !======================================================================= - INTEGER, PARAMETER :: Number_to_Echo = 10 + INTEGER, PARAMETER :: Number_to_Echo = 10 INTEGER :: ialpha #ifdef IHOP_THREED INTEGER :: ibeta @@ -61,7 +61,7 @@ SUBROUTINE ReadRayElevationAngles( Depth, TopOpt, RunType, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: Depth CHARACTER (LEN= 6), INTENT( IN ) :: TopOpt, RunType @@ -69,7 +69,7 @@ SUBROUTINE ReadRayElevationAngles( Depth, TopOpt, RunType, myThid ) IF ( TopOpt( 6:6 ) == 'I' ) THEN ! option to trace a single beam Angles%Nalpha = 0 - !READ( ENVFile, * ) Angles%Nalpha, Angles%iSingle_alpha + !READ( ENVFile, * ) Angles%Nalpha, Angles%iSingle_alpha ELSE Angles%Nalpha = IHOP_nalpha END IF @@ -77,15 +77,15 @@ SUBROUTINE ReadRayElevationAngles( Depth, TopOpt, RunType, myThid ) IF ( Angles%Nalpha == 0 ) THEN ! automatically estimate Nalpha to use IF ( RunType( 1:1 ) == 'R' ) THEN ! For a ray trace plot, we don't want too many rays ... - Angles%Nalpha = 50 + Angles%Nalpha = 50 ELSE ! you're letting ME choose? OK: ideas based on an isospeed ocean ! limit based on phase of adjacent beams at maximum range Angles%Nalpha = MAX( INT( 0.3*Pos%Rr( Pos%NRr )*IHOP_freq/c0 ), 300 ) - ! limit based on having beams that are thin with respect to the water - ! depth assumes also a full 360 degree angular spread of rays should - ! check which Depth is used here, in case where there is a variable + ! limit based on having beams that are thin with respect to the water + ! depth assumes also a full 360 degree angular spread of rays should + ! check which Depth is used here, in case where there is a variable ! bathymetry d_theta_recommended = ATAN( Depth / ( 10.0*Pos%Rr( Pos%NRr ) ) ) Angles%Nalpha = MAX( INT( PI / d_theta_recommended ), Angles%Nalpha ) @@ -138,7 +138,7 @@ SUBROUTINE ReadRayElevationAngles( Depth, TopOpt, RunType, myThid ) STOP 'ABNORMAL END: S/R ReadRayElevationAngles' END IF END IF - + RETURN END !SUBROUTINE ReadRayElevationAngles @@ -152,7 +152,7 @@ SUBROUTINE ReadRayBearingAngles( TopOpt, RunType, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN= 6), INTENT( IN ) :: TopOpt, RunType @@ -165,7 +165,7 @@ SUBROUTINE ReadRayBearingAngles( TopOpt, RunType, myThid ) IF ( TopOpt( 6 : 6 ) == 'I' ) THEN ! option to trace a single beam - !READ( ENVFile, * ) Angles%Nbeta, Angles%iSingle_beta + !READ( ENVFile, * ) Angles%Nbeta, Angles%iSingle_beta ELSE !READ( ENVFile, * ) Angles%Nbeta END IF @@ -173,7 +173,7 @@ SUBROUTINE ReadRayBearingAngles( TopOpt, RunType, myThid ) IF ( Angles%Nbeta == 0 ) THEN ! automatically estimate Nbeta to use IF ( RunType( 1 : 1 ) == 'R' ) THEN ! For a ray trace plot, we don't want too many rays ... - Angles%Nbeta = 50 + Angles%Nbeta = 50 ELSE Angles%Nbeta = MAX( INT( 0.1*Pos%rr( Pos%NRr )*IHOP_freq / c0 ), 300 ) END IF @@ -227,7 +227,7 @@ SUBROUTINE ReadRayBearingAngles( TopOpt, RunType, myThid ) END IF ! Nbeta should = Ntheta - Angles%beta( 1 : Angles%Nbeta ) = Pos%theta( 1 : Pos%Ntheta ) + Angles%beta( 1 : Angles%Nbeta ) = Pos%theta( 1 : Pos%Ntheta ) END IF #ifdef IHOP_WRITE_OUT diff --git a/src/arr_mod.F90 b/src/arr_mod.F90 index 2399dbc..253ed23 100644 --- a/src/arr_mod.F90 +++ b/src/arr_mod.F90 @@ -57,9 +57,9 @@ SUBROUTINE AddArr( afreq, iz, ir, Amp, Phase, delay, SrcDeclAngle, & ! ADDs the amplitude and delay for an ARRival into a matrix of same. ! Extra logic included to keep only the strongest arrivals. - + ! arrivals with essentially the same phase are grouped into one - REAL, PARAMETER :: PhaseTol = 0.05 + REAL, PARAMETER :: PhaseTol = 0.05 INTEGER, INTENT( IN ) :: NumTopBnc, NumBotBnc, iz, ir REAL (KIND=_RL90), INTENT( IN ) :: afreq, Amp, Phase, SrcDeclAngle, & RcvrDeclAngle @@ -67,14 +67,14 @@ SUBROUTINE AddArr( afreq, iz, ir, Amp, Phase, delay, SrcDeclAngle, & LOGICAL :: NewRay INTEGER :: iArr( 1 ), Nt REAL :: AmpTot, w1, w2 - + Nt = NArr( ir, iz ) ! # of arrivals NewRay = .TRUE. ! Is this the second bracketting ray of a pair? ! If so, we want to combine the arrivals to conserve space. ! (test this by seeing if the arrival time is close to the previous one) - ! (also need that the phase is about the same to make sure surface and + ! (also need that the phase is about the same to make sure surface and ! direct paths are not joined) IF ( Nt >= 1 ) THEN @@ -105,18 +105,18 @@ SUBROUTINE AddArr( afreq, iz, ir, Amp, Phase, delay, SrcDeclAngle, & Arr( Nt + 1, ir, iz)%NBotBnc = NumBotBnc ! # bottom bounces ENDIF ELSE ! not a new ray - ! calculate weightings of old ray information vs. new, based on + ! calculate weightings of old ray information vs. new, based on ! amplitude of the arrival AmpTot = Arr( Nt, ir, iz )%A + SNGL( Amp ) w1 = Arr( Nt, ir, iz )%A / AmpTot w2 = REAL( Amp ) / AmpTot - Arr( Nt, ir, iz)%delay = w1 * Arr( Nt, ir, iz )%delay & + Arr( Nt, ir, iz)%delay = w1 * Arr( Nt, ir, iz )%delay & + w2 * CMPLX( delay ) ! weighted sum Arr( Nt, ir, iz)%A = AmpTot - Arr( Nt, ir, iz)%SrcDeclAngle = w1 * Arr( Nt, ir, iz )%SrcDeclAngle & + Arr( Nt, ir, iz)%SrcDeclAngle = w1 * Arr( Nt, ir, iz )%SrcDeclAngle & + w2 * SNGL( SrcDeclAngle ) - Arr( Nt, ir, iz)%RcvrDeclAngle = w1 * Arr( Nt, ir, iz )%RcvrDeclAngle & + Arr( Nt, ir, iz)%RcvrDeclAngle = w1 * Arr( Nt, ir, iz )%RcvrDeclAngle & + w2 * SNGL( RcvrDeclAngle ) ENDIF @@ -157,7 +157,7 @@ SUBROUTINE WriteArrivalsASCII( r, Nrz, Nrr, SourceType ) #ifdef IHOP_WRITE_OUT WRITE( ARRFile, * ) NArr( ir, iz ) DO iArr = 1, NArr( ir, iz ) - ! You can compress the output file a lot by putting in an explicit + ! You can compress the output file a lot by putting in an explicit ! format statement here ... ! However, you'll need to make sure you keep adequate precision WRITE( ARRFile, * ) & diff --git a/src/atten_mod.F90 b/src/atten_mod.F90 index 2f70628..d266a21 100644 --- a/src/atten_mod.F90 +++ b/src/atten_mod.F90 @@ -7,7 +7,7 @@ MODULE atten_mod ! ! Attenuation module - ! Routines to convert a sound speed and attenuation in user units to a + ! Routines to convert a sound speed and attenuation in user units to a ! complex sound speed ! Includes a formula for volume attenuation @@ -31,11 +31,11 @@ MODULE atten_mod public CRCI, T, Salinity, pH, z_bar, iBio, NBioLayers, bio !======================================================================= - + INTEGER, PARAMETER :: MaxBioLayers = 200 INTEGER :: iBio, NBioLayers ! Francois-Garrison volume attenuation; temperature, salinity, ... - REAL (KIND=_RL90) :: T = 20, Salinity = 35, pH = 8, z_bar = 0, FG + REAL (KIND=_RL90) :: T = 20, Salinity = 35, pH = 8, z_bar = 0, FG TYPE bioStructure REAL (KIND=_RL90) :: Z1, Z2, f0, Q, a0 @@ -64,7 +64,7 @@ FUNCTION CRCI( z, c, alpha, AttenUnit, beta, fT, myThid ) ! B for biological ! ! freq is the current frequency - ! freq0 is the reference frequency for which the dB/meter was specified + ! freq0 is the reference frequency for which the dB/meter was specified ! (used only for 'm') ! Returns @@ -79,7 +79,7 @@ FUNCTION CRCI( z, c, alpha, AttenUnit, beta, fT, myThid ) afreq = 2.0 * PI * IHOP_freq - ! Convert to Nepers/m + ! Convert to Nepers/m alphaT = 0.0 SELECT CASE ( AttenUnit( 1 : 1 ) ) CASE ( 'N' ) @@ -139,7 +139,7 @@ FUNCTION CRCI( z, c, alpha, AttenUnit, beta, fT, myThid ) END DO END SELECT - ! Convert Nepers/m to equivalent imaginary sound speed + ! Convert Nepers/m to equivalent imaginary sound speed alphaT = alphaT * c * c / afreq CRCI = CMPLX( c, alphaT, KIND=_RL90 ) diff --git a/src/bdry_mod.F90 b/src/bdry_mod.F90 index 66e4ea7..35ace4a 100644 --- a/src/bdry_mod.F90 +++ b/src/bdry_mod.F90 @@ -41,13 +41,13 @@ MODULE bdry_mod INTEGER :: IOStat, IAllocStat ! range intervals defining the current active segment - REAL (KIND=_RL90) :: rTopseg( 2 ), rBotseg( 2 ) + REAL (KIND=_RL90) :: rTopseg( 2 ), rBotseg( 2 ) CHARACTER (LEN=2) :: atiType= 'LS', btyType = 'LS' ! ***Halfspace properties*** TYPE HSInfo ! compressional and shear wave speeds/attenuations in user units - REAL (KIND=_RL90) :: alphaR, alphaI, betaR, betaI + REAL (KIND=_RL90) :: alphaR, alphaI, betaR, betaI REAL (KIND=_RL90) :: rho, Depth ! density, depth COMPLEX (KIND=_RL90) :: cP, cS ! P-wave, S-wave speeds CHARACTER(LEN=1) :: BC ! Boundary condition type @@ -62,7 +62,7 @@ MODULE bdry_mod REAL (KIND=_RL90) :: Len, Kappa ! length and curvature of a segement ! For the curvilinear grid option REAL (KIND=_RL90) :: Nodet( 2 ), & ! tangent at the node - Noden( 2 ) ! normal at the node + Noden( 2 ) ! normal at the node REAL (KIND=_RL90) :: Dx, Dxx, & ! 1st, 2nd derivatives wrt depth Dss ! derivative along tangent TYPE( HSInfo ) :: HS @@ -81,7 +81,7 @@ MODULE bdry_mod TYPE(BdryType) :: Bdry CONTAINS - SUBROUTINE initATI( TopATI, DepthT, myThid ) + SUBROUTINE initATI( TopATI, DepthT, myThid ) ! Reads in the top altimetry ! IESCO24 ! fT = 1000 ONLY for acousto-elastic halfspaces, I will have to pass this @@ -93,13 +93,13 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN= 1), INTENT( IN ) :: TopATI INTEGER :: ii REAL (KIND=_RL90), INTENT( IN ) :: DepthT REAL (KIND=_RL90), ALLOCATABLE :: phi(:) - REAL (KIND=_RL90), ALLOCATABLE :: x(:) + REAL (KIND=_RL90), ALLOCATABLE :: x(:) REAL (KIND=_RL90) :: bPower, fT ! IESCO24 fT init @@ -115,7 +115,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) WRITE(msgBuf,'(2A)') '______________________________________________', & '_____________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Using top-altimetry file' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -173,7 +173,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) #endif /* IHOP_WRITE_OUT */ ! we'll be extending the altimetry to infinity to the left and right - NAtiPts = NAtiPts + 2 + NAtiPts = NAtiPts + 2 IF (ALLOCATED(Top)) DEALLOCATE(Top) ALLOCATE( Top( NAtiPts ), Stat = IAllocStat ) @@ -189,7 +189,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') ' Range (km) Depth (m)' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -203,8 +203,8 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) CASE ( 'S', '' ) READ( ATIFile, * ) Top( ii )%x #ifdef IHOP_WRITE_OUT - IF ( ii < Number_to_Echo .OR. ii == NAtiPts ) THEN - WRITE( msgBuf,"(2G11.3)" ) Top( ii )%x + IF ( ii < Number_to_Echo .OR. ii == NAtiPts ) THEN + WRITE( msgBuf,"(2G11.3)" ) Top( ii )%x CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END IF #endif /* IHOP_WRITE_OUT */ @@ -213,7 +213,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) Top( ii )%HS%betaR, Top( ii )%HS%rho, & Top( ii )%HS%alphaI, Top( ii )%HS%betaI #ifdef IHOP_WRITE_OUT - IF ( ii < Number_to_Echo .OR. ii == NAtiPts ) THEN + IF ( ii < Number_to_Echo .OR. ii == NAtiPts ) THEN WRITE( msgBuf,"(7G11.3)" ) & Top( ii )%x, Top( ii )%HS%alphaR, Top( ii )%HS%betaR, & Top( ii )%HS%rho, Top( ii )%HS%alphaI, Top( ii )%HS%betaI @@ -271,7 +271,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R initATI' - END IF + END IF ! Initiate Top DO ii = 1, NAtiPts @@ -287,7 +287,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) ! compressional wave speed Top( ii )%HS%cP = CRCI( 1D20, Top( ii )%HS%alphaR, & Top( ii )%HS%alphaI, 'W ', bPower, fT, & - myThid ) + myThid ) ! shear wave speed Top( ii )%HS%cS = CRCI( 1D20, Top( ii )%HS%betaR, & Top( ii )%HS%betaI, 'W ', bPower, fT, & @@ -295,7 +295,7 @@ SUBROUTINE initATI( TopATI, DepthT, myThid ) END DO END IF - + RETURN END !SUBROUTINE initATI @@ -313,13 +313,13 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN= 1), INTENT( IN ) :: BotBTY INTEGER :: i,j,bi,bj,ii REAL (KIND=_RL90), INTENT( IN ) :: DepthB REAL (KIND=_RL90) :: gcmbathy(sNx,sNy), gcmmin, gcmmax - REAL (KIND=_RL90), ALLOCATABLE :: x(:) + REAL (KIND=_RL90), ALLOCATABLE :: x(:) LOGICAL :: firstnonzero REAL (KIND=_RL90) :: bPower, fT @@ -335,7 +335,7 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) WRITE(msgBuf,'(2A)')'____________________________________________', & '_______________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Using bottom-bathymetry file' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -356,9 +356,9 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) # endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R initBTY' END IF - + READ( BTYFile, * ) btyType - + ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN SELECT CASE ( btyType( 1:1 ) ) @@ -393,8 +393,8 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) #endif /* IHOP_WRITE_OUT */ ! we'll be extending the bathymetry to infinity on both sides - NBtyPts = NBtyPts + 2 - + NBtyPts = NBtyPts + 2 + ALLOCATE( Bot( NBtyPts ), Stat = IAllocStat ) IF ( IAllocStat /= 0 ) THEN # ifdef IHOP_WRITE_OUT @@ -404,12 +404,12 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) # endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R initBTY' END IF - + ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) #endif /* IHOP_WRITE_OUT */ SELECT CASE ( btyType( 2:2 ) ) @@ -427,7 +427,7 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) WRITE(msgBuf,'(A)') & ' Range (km) Depth (m) alphaR (m/s) betaR rho (g/cm^3) alphaI betaI' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) # endif /* IHOP_WRITE_OUT */ CASE DEFAULT @@ -476,7 +476,7 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) 'gcm:', gcmmax CALL PRINT_MESSAGE(msgBuf, errorMessageUnit, SQUEEZE_RIGHT, myThid) END IF - IF ( ii < Number_to_Echo .OR. ii == NBtyPts ) THEN + IF ( ii < Number_to_Echo .OR. ii == NBtyPts ) THEN WRITE(msgBuf,'(2G11.3)' ) Bot( ii )%x ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) & @@ -488,7 +488,7 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) Bot( ii )%HS%betaR, Bot( ii )%HS%rho, & Bot( ii )%HS%alphaI, Bot( ii )%HS%betaI # ifdef IHOP_WRITE_OUT - IF ( ii < Number_to_Echo .OR. ii == NBtyPts ) THEN + IF ( ii < Number_to_Echo .OR. ii == NBtyPts ) THEN WRITE( msgBuf,'(2F10.2,3X,2F10.2,3X,F6.2,3X,2F10.4)' ) & Bot( ii )%x, Bot( ii )%HS%alphaR, Bot( ii )%HS%betaR, & Bot( ii )%HS%rho, Bot( ii )%HS%alphaI, Bot( ii )%HS%betaI @@ -560,7 +560,7 @@ SUBROUTINE initBTY( BotBTY, DepthB, myThid ) CALL PRINT_ERROR( msgBuf,myThid ) # endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R initBTY' - END IF + END IF ! Initiate Bot @@ -598,7 +598,7 @@ SUBROUTINE ComputeBdryTangentNormal( Bdry, BotTop, NPts ) ! normals (%n, %noden), and ! curvatures (%kappa) ! - ! The boundary is also extended with a constant depth to infinity to cover + ! The boundary is also extended with a constant depth to infinity to cover ! cases where the ray leaves the domain defined by the user INTEGER, INTENT(IN) :: NPts @@ -649,10 +649,10 @@ SUBROUTINE ComputeBdryTangentNormal( Bdry, BotTop, NPts ) END DO BoundaryPt - ! curvilinear option: compute tangent and normal at node by averaging + ! curvilinear option: compute tangent and normal at node by averaging ! normals on adjacent segments - IF ( CurvilinearFlag( 1 : 1 ) == 'C' ) THEN - ! averaging two centered differences is equivalent to forming a single + IF ( CurvilinearFlag( 1 : 1 ) == 'C' ) THEN + ! averaging two centered differences is equivalent to forming a single ! centered difference of two steps ... DO ii = 2, NPts - 1 sss = Bdry( ii - 1 )%Len / ( Bdry( ii - 1 )%Len + Bdry( ii )%Len ) @@ -682,10 +682,10 @@ SUBROUTINE ComputeBdryTangentNormal( Bdry, BotTop, NPts ) ! this is curvature = dphi/ds Bdry( ii )%kappa = ( phi( ii+1 ) - phi( ii ) ) / Bdry( ii )%Len ! second derivative - Bdry( ii )%Dxx = ( Bdry( ii+1 )%Dx - Bdry( ii )%Dx ) / & + Bdry( ii )%Dxx = ( Bdry( ii+1 )%Dx - Bdry( ii )%Dx ) / & ( Bdry( ii+1 )%x( 1 ) - Bdry( ii )%x( 1 ) ) ! derivative in direction of tangent - Bdry( ii )%Dss = Bdry( ii )%Dxx * Bdry( ii )%t( 1 )**3 + Bdry( ii )%Dss = Bdry( ii )%Dxx * Bdry( ii )%t( 1 )**3 Bdry( ii )%kappa = Bdry( ii )%Dss !over-ride kappa !!!!! END DO @@ -707,7 +707,7 @@ SUBROUTINE GetTopSeg( r, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER IsegTopT( 1 ) REAL (KIND=_RL90), INTENT( IN ) :: r @@ -715,10 +715,10 @@ SUBROUTINE GetTopSeg( r, myThid ) IsegTopT = MAXLOC( Top( : )%x( 1 ), Top( : )%x( 1 ) < r ) ! IsegTop MUST LIE IN [ 1, NAtiPts-1 ] - IF ( IsegTopT( 1 ) > 0 .AND. IsegTopT( 1 ) < NAtiPts ) THEN + IF ( IsegTopT( 1 ) > 0 .AND. IsegTopT( 1 ) < NAtiPts ) THEN IsegTop = IsegTopT( 1 ) ! segment limits in range - rTopSeg = [ Top( IsegTop )%x( 1 ), Top( IsegTop+1 )%x( 1 ) ] + rTopSeg = [ Top( IsegTop )%x( 1 ), Top( IsegTop+1 )%x( 1 ) ] ELSE #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run @@ -750,7 +750,7 @@ SUBROUTINE GetBotSeg( r, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER IsegBotT( 1 ) REAL (KIND=_RL90), INTENT( IN ) :: r @@ -758,7 +758,7 @@ SUBROUTINE GetBotSeg( r, myThid ) IsegBotT = MAXLOC( Bot( : )%x( 1 ), Bot( : )%x( 1 ) < r ) ! IsegBot MUST LIE IN [ 1, NBtyPts-1 ] IF ( IsegBotT( 1 ) > 0 .AND. IsegBotT( 1 ) < NBtyPts ) THEN - IsegBot = IsegBotT( 1 ) + IsegBot = IsegBotT( 1 ) ! segment limits in range rBotSeg = [ Bot( IsegBot )%x( 1 ), Bot( IsegBot + 1 )%x( 1 ) ] ELSE diff --git a/src/beampattern.F90 b/src/beampattern.F90 index 6f56df9..99986e4 100644 --- a/src/beampattern.F90 +++ b/src/beampattern.F90 @@ -38,7 +38,7 @@ SUBROUTINE ReadPat( myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER :: I, IAllocStat, IOStat diff --git a/src/bellhop.F90 b/src/bellhop.F90 index 129984e..a739fb0 100644 --- a/src/bellhop.F90 +++ b/src/bellhop.F90 @@ -21,13 +21,13 @@ MODULE BELLHOP ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . - ! First version (1983) originally developed with Homer Bucker, Naval Ocean + ! First version (1983) originally developed with Homer Bucker, Naval Ocean ! Systems Center - + USE ihop_mod, only: rad2deg, i, Beam, ray2D, NRz_per_range, afreq, & SrcDeclAngle, iSmallStepCtr, & - PRTFile, SHDFile, ARRFile, RAYFile, DELFile + PRTFile, SHDFile, ARRFile, RAYFile, DELFile USE angle_mod, only: Angles, ialpha USE srPos_mod, only: Pos USE ssp_mod, only: evalSSP, SSP @@ -40,7 +40,7 @@ MODULE BELLHOP USE influence, only: InfluenceGeoHatRayCen, & InfluenceGeoGaussianCart, InfluenceGeoHatCart, & ScalePressure - USE beamPattern + USE beamPattern USE writeRay, only: WriteRay2D, WriteDel2D USE arr_mod, only: WriteArrivalsASCII,WriteArrivalsBinary,MaxNArr, & Arr, NArr, U @@ -74,7 +74,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) INTEGER, INTENT( IN ) :: myIter INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER :: iAllocStat REAL :: Tstart, Tstop @@ -82,7 +82,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ! =========================================================================== INTEGER, PARAMETER :: ArrivalsStorage = 2000, MinNArr = 10 ! =========================================================================== - + !!$TAF init ihop_init1 = 'BellhopIhop_init' ! !! IESCO24: Write derived type with allocatable memory by type: Pos from srpos_mod @@ -98,7 +98,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) !!$TAF store ssp%czmat,ssp%seg%r,ssp%seg%x,ssp%seg%y,ssp%seg%z = ihop_init1 ! Reset memory - CALL resetMemory() + CALL resetMemory() ! save data.ihop, open PRTFile: REQUIRED CALL initPRTFile( myTime, myIter, myThid ) @@ -131,7 +131,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CALL initBTY( Bdry%Bot%HS%Opt( 2:2 ), Bdry%Bot%HS%Depth, myThid ) ! (top and bottom): OPTIONAL CALL readReflectionCoefficient( Bdry%Bot%HS%Opt( 1:1 ), & - Bdry%Top%HS%Opt( 2:2 ), myThid ) + Bdry%Top%HS%Opt( 2:2 ), myThid ) ! Source Beam Pattern: OPTIONAL, default is omni source pattern SBPFlag = Beam%RunType( 3:3 ) CALL readPat( myThid ) @@ -146,22 +146,22 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) STOP 'ABNORMAL END: S/R IHOP_INIT' ENDIF Pos%theta( 1 ) = 0. - - ! Allocate arrival and U variables on all MPI processes + + ! Allocate arrival and U variables on all MPI processes SELECT CASE ( Beam%RunType( 5:5 ) ) CASE ( 'I' ) NRz_per_range = 1 ! irregular grid CASE DEFAULT NRz_per_range = Pos%NRz ! rectilinear grid END SELECT - + SELECT CASE ( Beam%RunType( 1:1 ) ) ! for a TL calculation, allocate space for the pressure matrix CASE ( 'C', 'S', 'I' ) ! TL calculation ALLOCATE( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) IF ( iAllocStat/=0 ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & + WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & 'Insufficient memory for TL matrix: reduce Nr*NRz' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -175,12 +175,12 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ALLOCATE( U( 1,1 ) ) ! open a dummy variable U( 1,1 ) = 0. ! init default value END SELECT - + ! for an arrivals run, allocate space for arrivals matrices SELECT CASE ( Beam%RunType( 1:1 ) ) CASE ( 'A', 'a', 'e' ) ! allow space for at least MinNArr arrivals - MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & + MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & MinNArr ) CASE DEFAULT MaxNArr = 1 @@ -191,7 +191,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) NArr(Pos%NRr, NRz_per_range), STAT = iAllocStat ) IF ( iAllocStat /= 0 ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & + WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & 'Not enough allocation for Arr; reduce ArrivalsStorage' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -206,9 +206,9 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) Arr(:,:,:)%A = -999. Arr(:,:,:)%Phase = -999. Arr(:,:,:)%delay = -999. - + #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) & CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) @@ -219,7 +219,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ! open all output files IF ( IHOP_dumpfreq .GE. 0 ) & CALL OpenOutputFiles( IHOP_fileroot, myTime, myIter, myThid ) - + ! Run Bellhop solver on a single processor if (numberOfProcs.gt.1) then ! Use same single processID as IHOP COST package @@ -228,7 +228,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CALL CPU_TIME( Tstart ) CALL BellhopCore(myThid) CALL CPU_TIME( Tstop ) -! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. +! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. !#ifdef ALLOW_COST ! ! Broadcast info to all MPI procs for COST function accumulation ! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) @@ -240,7 +240,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CALL BellhopCore(myThid) CALL CPU_TIME( Tstop ) endif - + #ifdef IHOP_WRITE_OUT IF ( IHOP_dumpfreq.GE.0 ) THEN ! print run time @@ -255,7 +255,7 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) WRITE(msgBuf, '(A,G15.3,A)' ) 'CPU Time = ', Tstop-Tstart, 's' CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) - + ! close all files SELECT CASE ( Beam%RunType( 1:1 ) ) CASE ( 'C', 'S', 'I' ) ! TL calculation @@ -266,11 +266,11 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) CLOSE( RAYFile ) IF ( writeDelay ) CLOSE( DELFile ) CASE ( 'e' ) - CLOSE( RAYFile ) + CLOSE( RAYFile ) CLOSE( ARRFile ) IF ( writeDelay ) CLOSE( DELFile ) END SELECT - + if (numberOfProcs.gt.1) then ! Erase prtfiles that aren't on procid = 0 if(myProcId.ne.0) then @@ -284,10 +284,10 @@ SUBROUTINE IHOP_INIT ( myTime, myIter, myThid ) ENDIF #endif /* IHOP_WRITE_OUT */ - + RETURN END !SUBROUTINE IHOP_INIT - + ! **********************************************************************! SUBROUTINE BellhopCore( myThid ) USE ssp_mod, only: iSegr !RG @@ -297,7 +297,7 @@ SUBROUTINE BellhopCore( myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER :: IBPvec(1), ibp, is, iBeamWindow2, Irz1, Irec, & NalphaOpt @@ -308,7 +308,7 @@ SUBROUTINE BellhopCore( myThid ) !$TAF init BellhopCore2 = static, Pos%NSz*Angles%Nalpha afreq = 2.0 * PI * IHOP_freq - + Angles%alpha = Angles%alpha * deg2rad ! convert to radians Angles%Dalpha = 0.0 IF ( Angles%Nalpha > 1 ) THEN @@ -316,13 +316,13 @@ SUBROUTINE BellhopCore( myThid ) / ( Angles%Nalpha - 1 ) ! angular spacing between beams ELSE #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP BellhopCore: ', & + WRITE(msgBuf,'(2A)') 'BELLHOP BellhopCore: ', & 'Required: Nalpha>1, else add iSingle_alpha(see angleMod)' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R BellhopCore' END IF - + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! begin solve ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -335,16 +335,16 @@ SUBROUTINE BellhopCore( myThid ) !$TAF store ssp%cmat,ssp%czmat = BellhopCore1 xs = [ zeroRL, Pos%Sz( is ) ] ! source coordinate, assuming source @ r=0 - + SELECT CASE ( Beam%RunType( 1:1 ) ) CASE ( 'C','S','I' ) ! TL calculation, zero out pressure matrix U = 0.0 CASE ( 'A','a','e' ) ! Arrivals calculation, zero out arrival matrix NArr = 0 END SELECT - + CALL evalSSP( xs, c, cimag, gradc, crr, crz, czz, rho, myThid ) - + !!IESCO22: BEAM stuff !! RadMax = 5 * c / IHOP_freq ! 5 wavelength max radius IEsco22: unused IF ( Beam%RunType( 1:1 ) == 'C' ) THEN ! for Coherent TL Run @@ -363,7 +363,7 @@ SUBROUTINE BellhopCore( myThid ) #endif /* IHOP_WRITE_OUT */ ENDIF !!IESCO22: end BEAM stuff !! - + ! Trace successive beams DeclinationAngle: DO ialpha = 1, Angles%Nalpha @@ -385,10 +385,10 @@ SUBROUTINE BellhopCore( myThid ) ! take-off declination angle in degrees SrcDeclAngle = rad2deg * Angles%alpha( ialpha ) - + ! Single ray run? then don't visit code below IF ( Angles%iSingle_alpha==0 .OR. ialpha==Angles%iSingle_alpha ) THEN - + !!IESCO22: BEAM stuff !! IBPvec = maxloc( SrcBmPat( :, 1 ), mask = SrcBmPat( :, 1 ) & < SrcDeclAngle ) ! index of ray angle in beam pattern @@ -396,13 +396,13 @@ SUBROUTINE BellhopCore( myThid ) IBP = MAX( IBP, 1 ) ! don't go before beginning of table IBP = MIN( IBP, NSBPPts - 1 ) ! don't go past end of table ! IEsco22: When a beam pattern isn't specified, IBP = 1 - + ! linear interpolation to get amplitude s = ( SrcDeclAngle - SrcBmPat( IBP, 1 ) ) & / ( SrcBmPat( IBP + 1, 1 ) - SrcBmPat( IBP, 1 ) ) Amp0 = ( 1 - s ) * SrcBmPat( IBP, 2 ) + s * SrcBmPat( IBP + 1, 2 ) ! IEsco22: When a beam pattern isn't specified, Amp0 = 0 - + !$TAF store amp0,beam%runtype,beam%nsteps = BellhopCore2 ! IESCO24: Write derived type with allocatable memory by type: Bdry from bdry_mod ! Scalar components @@ -416,7 +416,7 @@ SUBROUTINE BellhopCore( myThid ) Amp0 = Amp0 * SQRT( 2.0 ) * ABS( SIN( afreq / c * xs( 2 ) & * SIN( Angles%alpha( ialpha ) ) ) ) !!IESCO22: end BEAM stuff !! - + #ifdef IHOP_WRITE_OUT ! report progress in PRTFile (skipping some angles) IF ( MOD( ialpha - 1, max( Angles%Nalpha / 50, 1 ) ) == 0 ) THEN @@ -428,12 +428,12 @@ SUBROUTINE BellhopCore( myThid ) FLUSH( PRTFile ) END IF #endif /* IHOP_WRITE_OUT */ - + ! Trace a ray, update ray2D structure - CALL TraceRay2D( xs, Angles%alpha( ialpha ), Amp0, myThid ) - + CALL TraceRay2D( xs, Angles%alpha( ialpha ), Amp0, myThid ) + ! Write the ray trajectory to RAYFile - IF ( Beam%RunType(1:1) == 'R') THEN + IF ( Beam%RunType(1:1) == 'R') THEN CALL WriteRay2D( SrcDeclAngle, Beam%Nsteps ) IF (writeDelay) CALL WriteDel2D( SrcDeclAngle, Beam%Nsteps ) ELSE ! Compute the contribution to the field @@ -452,12 +452,12 @@ SUBROUTINE BellhopCore( myThid ) Angles%Dalpha, myThid ) END SELECT END IF - + END IF END DO DeclinationAngle - + ! write results to disk - + SELECT CASE ( Beam%RunType( 1:1 ) ) CASE ( 'C', 'S', 'I' ) ! TL calculation CALL ScalePressure( Angles%Dalpha, ray2D( 1 )%c, Pos%Rr, U, & @@ -474,18 +474,18 @@ SUBROUTINE BellhopCore( myThid ) CALL WriteArrivalsBinary( Pos%Rr, NRz_per_range, Pos%NRr, & Beam%RunType( 4:4 ) ) END SELECT - + END DO SourceDepth - + RETURN END !SUBROUTINE BellhopCore - + ! **********************************************************************! - + SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) - + ! Traces the beam corresponding to a particular take-off angle, alpha [rad] - + USE ihop_mod, only: MaxN, istep USE step, only: Step2D USE ssp_mod, only: iSegr !RG @@ -494,7 +494,7 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: xs(2) ! coordinate of source REAL (KIND=_RL90), INTENT( IN ) :: alpha, Amp0 ! angle in rad, beam amp @@ -503,11 +503,11 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) REAL (KIND=_RL90) :: dEndTop(2), dEndBot(2), TopnInt(2), BotnInt(2), & ToptInt(2), BottInt(2), rayt(2), raytOld(2) ! Distances from ray beginning, end to top and bottom - REAL (KIND=_RL90) :: DistBegTop, DistEndTop, DistBegBot, DistEndBot + REAL (KIND=_RL90) :: DistBegTop, DistEndTop, DistBegBot, DistEndBot REAL (KIND=_RL90) :: sss, declAlpha, declAlphaOld LOGICAL :: RayTurn = .FALSE., continue_steps - -!$TAF init TraceRay2D = static, MaxN-1 + +!$TAF init TraceRay2D = static, MaxN-1 !$TAF init TraceRay2D1 = 'bellhop_traceray2d' ! IESCO24: Write derived type with allocatable memory by type: Bdry from bdry_mod @@ -524,10 +524,10 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) ray2D( 1 )%p = [ 1.0, 0.0 ] ! IESCO22: slowness vector ! second component of qv is not supported in geometric beam tracing ! set I.C. to 0 in hopes of saving run time - IF ( Beam%RunType( 2:2 ) == 'G' .or. Beam%RunType( 2:2 ) == 'B') THEN + IF ( Beam%RunType( 2:2 ) == 'G' .or. Beam%RunType( 2:2 ) == 'B') THEN ray2D( 1 )%q = [ 0.0, 0.0 ] ! IESCO22: geometric beam in Cartesian ELSE - ray2D( 1 )%q = [ 0.0, 1.0 ] ! IESCO22: ray centered coords + ray2D( 1 )%q = [ 0.0, 1.0 ] ! IESCO22: ray centered coords END IF ray2D( 1 )%tau = 0.0 ray2D( 1 )%Amp = Amp0 @@ -535,16 +535,16 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) ray2D( 1 )%NumTopBnc = 0 ray2D( 1 )%NumBotBnc = 0 ray2D( 1 )%NumTurnPt = 0 - + ! IESCO22: update IsegTop, rTopSeg and IsegBot, rBotSeg in bdrymod.f90 CALL GetTopSeg( xs(1), myThid ) ! find alimetry segment above the source CALL GetBotSeg( xs(1), myThid ) ! find bathymetry segment below the source - + ! IESCO22: 'L' is long format. See BeadBTY s/r in bdrymod.f90. Default is to ! calculate cp, cs, and rho instead of reading them in IF ( atiType( 2 : 2 ) == 'L' ) THEN ! grab the geoacoustic info for the new segment - Bdry%Top%HS%cp = Top( IsegTop )%HS%cp + Bdry%Top%HS%cp = Top( IsegTop )%HS%cp Bdry%Top%HS%cs = Top( IsegTop )%HS%cs Bdry%Top%HS%rho = Top( IsegTop )%HS%rho END IF @@ -553,12 +553,12 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) Bdry%Bot%HS%cs = Bot( IsegBot )%HS%cs Bdry%Bot%HS%rho = Bot( IsegBot )%HS%rho END IF - + CALL Distances2D( ray2D( 1 )%x, Top( IsegTop )%x, Bot( IsegBot )%x, & dEndTop, dEndBot, & Top( IsegTop )%n, Bot( IsegBot )%n, & DistBegTop, DistBegBot ) - + IF ( DistBegTop <= 0 .OR. DistBegBot <= 0 ) THEN Beam%Nsteps = 1 #ifdef IHOP_WRITE_OUT @@ -570,7 +570,7 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) #endif /* IHOP_WRITE_OUT */ RETURN ! source must be within the domain END IF - + ! Trace the beam (Reflect2D increments the step index, is) is = 0 @@ -592,65 +592,65 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) IF ( continue_steps ) THEN is = is + 1 ! old step is1 = is + 1 ! new step forward - + !$TAF store is,isegbot,isegtop,rbotseg,rtopseg = TraceRay2D !$TAF store ray2d = TraceRay2D CALL Step2D( ray2D( is ), ray2D( is1 ), & Top( IsegTop )%x, Top( IsegTop )%n, & Bot( IsegBot )%x, Bot( IsegBot )%n, myThid ) - + ! IESCO22: turning point check IF ( is > 1 ) THEN rayt = ray2D(is1)%x - ray2D(is)%x raytOld = ray2D(is)%x - ray2D(is-1)%x - declAlpha = ATAN2( rayt(2), rayt(1) ) - declAlphaOld = ATAN2( raytOld(2), raytOld(1) ) + declAlpha = ATAN2( rayt(2), rayt(1) ) + declAlphaOld = ATAN2( raytOld(2), raytOld(1) ) RayTurn = ( declAlpha <= 0.0d0 .AND. declAlphaOld > 0.0d0 .OR. & declAlpha >= 0.0d0 .AND. declAlphaOld < 0.0d0 ) IF ( RayTurn) THEN ray2D( is1 )%NumTurnPt = ray2D( is )%NumTurnPt + 1 END IF END IF - + ! New altimetry segment? IF ( ray2D( is1 )%x( 1 ) < rTopSeg( 1 ) .OR. & ray2D( is1 )%x( 1 ) > rTopSeg( 2 ) ) THEN CALL GetTopSeg( ray2D( is1 )%x( 1 ), myThid ) IF ( atiType( 2 : 2 ) == 'L' ) THEN ! ATIFile geoacoustic info from new segment, cp - Bdry%Top%HS%cp = Top( IsegTop )%HS%cp + Bdry%Top%HS%cp = Top( IsegTop )%HS%cp Bdry%Top%HS%cs = Top( IsegTop )%HS%cs Bdry%Top%HS%rho = Top( IsegTop )%HS%rho END IF END IF - + ! New bathymetry segment? IF ( ray2D( is1 )%x( 1 ) < rBotSeg( 1 ) .OR. & ray2D( is1 )%x( 1 ) > rBotSeg( 2 ) ) THEN CALL GetBotSeg( ray2D( is1 )%x( 1 ), myThid ) IF ( btyType( 2 : 2 ) == 'L' ) THEN ! BTYFile geoacoustic info from new segment, cp - Bdry%Bot%HS%cp = Bot( IsegBot )%HS%cp + Bdry%Bot%HS%cp = Bot( IsegBot )%HS%cp Bdry%Bot%HS%cs = Bot( IsegBot )%HS%cs Bdry%Bot%HS%rho = Bot( IsegBot )%HS%rho END IF END IF - + ! *** Reflections *** ! Tests ray at step is IS inside, and ray at step is+1 IS outside ! DistBeg is the distance at step is, which is saved ! DistEnd is the distance at step is+1, which needs to be calculated - + CALL Distances2D( ray2D( is1 )%x, & Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) - + ! IESCO22: Did new ray point cross top boundary? Then reflect - IF ( DistBegTop > 0.0d0 .AND. DistEndTop <= 0.0d0 ) THEN + IF ( DistBegTop > 0.0d0 .AND. DistEndTop <= 0.0d0 ) THEN !$TAF store isegtop = TraceRay2D - + IF ( atiType == 'C' ) THEN ! curvilinear interpolation ! proportional distance along segment sss = DOT_PRODUCT( dEndTop, Top( IsegTop )%t ) & @@ -663,22 +663,22 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) TopnInt = Top( IsegTop )%n ! normal is constant in a segment ToptInt = Top( IsegTop )%t END IF - + !$TAF store is,isegtop = TraceRay2D - + CALL Reflect2D( is, Bdry%Top%HS, 'TOP', ToptInt, TopnInt, & Top( IsegTop )%kappa, RTop, NTopPTS, & - myThid ) - + myThid ) + CALL Distances2D( ray2D( is+1 )%x, & Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) - + ! IESCO22: Did ray cross bottom boundary? Then reflect ELSE IF ( DistBegBot > 0.0d0 .AND. DistEndBot <= 0.0d0 ) THEN - + !$TAF store isegbot = TraceRay2D - + IF ( btyType == 'C' ) THEN ! curvilinear interpolation ! proportional distance along segment sss = DOT_PRODUCT( dEndBot, Bot( IsegBot )%t ) & @@ -691,19 +691,19 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) BotnInt = Bot( IsegBot )%n ! normal is constant in a segment BottInt = Bot( IsegBot )%t END IF - + !$TAF store is,isegbot = TraceRay2D CALL Reflect2D( is, Bdry%Bot%HS, 'BOT', BottInt, BotnInt, & Bot( IsegBot )%kappa, RBot, NBotPTS, & - myThid ) - + myThid ) + CALL Distances2D( ray2D( is+1 )%x, & Top( IsegTop )%x, Bot( IsegBot )%x, dEndTop, dEndBot, & Top( IsegTop )%n, Bot( IsegBot )%n, DistEndTop, DistEndBot ) END IF - - ! Has the ray left the box, lost its energy, escaped the boundaries, + + ! Has the ray left the box, lost its energy, escaped the boundaries, ! or exceeded storage limit? ! IESCO22: Rewriting for debugging with gcov WRITE(msgBuf,'(A)') ' ' @@ -711,11 +711,11 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box%r' ELSE IF ( ray2D( is+1 )%x( 1 ) < 0 ) THEN WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box r=0' - ELSE IF ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) THEN + ELSE IF ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) THEN WRITE(msgBuf,'(A)') 'TraceRay2D: ray left Box%z' ELSE IF ( ABS( ray2D( is+1 )%Amp ) < 0.005 ) THEN WRITE(msgBuf,'(A)') 'TraceRay2D: ray lost energy' - ELSE IF ( DistBegTop < 0.0 .AND. DistEndTop < 0.0 ) THEN + ELSE IF ( DistBegTop < 0.0 .AND. DistEndTop < 0.0 ) THEN WRITE(msgBuf,'(A)') 'TraceRay2D: ray escaped top bound' ELSE IF ( DistBegBot < 0.0 .AND. DistEndBot < 0.0 ) THEN WRITE(msgBuf,'(A)') 'TraceRay2D: ray escaped bot bound' @@ -723,9 +723,9 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) WRITE(msgBuf,'(2A)') 'WARNING: TraceRay2D: Check storage ',& 'for ray trajectory' END IF - + #ifdef IHOP_WRITE_OUT - IF ( ( ray2D( is+1 )%x( 1 ) > Beam%Box%r ) .OR. & + IF ( ( ray2D( is+1 )%x( 1 ) > Beam%Box%r ) .OR. & ( ray2D( is+1 )%x( 1 ) < 0 ) .OR. & ( ray2D( is+1 )%x( 2 ) > Beam%Box%z ) .OR. & ( ABS( ray2D( is+1 )%Amp ) < 0.005 ) .OR. & @@ -742,50 +742,50 @@ SUBROUTINE TraceRay2D( xs, alpha, Amp0, myThid ) ELSE IF (INDEX(msgBuf, 'WARNING: TraceRay2D').eq.1) THEN Beam%Nsteps = is continue_steps = .false. - END IF + END IF DistBegTop = DistEndTop DistBegBot = DistEndBot - END IF ! continue_steps + END IF ! continue_steps END DO Stepping - + RETURN END !SUBROUTINE TraceRay2D - + ! **********************************************************************! - + SUBROUTINE Distances2D( rayx, Topx, Botx, dTop, dBot, Topn, Botn, DistTop, & DistBot ) - + ! Calculates the distances to the boundaries ! Formula differs from JKPS because code applies outward pointing normals - + REAL (KIND=_RL90), INTENT( IN ) :: rayx(2) ! ray coordinate REAL (KIND=_RL90), INTENT( IN ) :: Topx(2), Botx(2) ! top, bottom coordinate REAL (KIND=_RL90), INTENT( IN ) :: Topn(2), Botn(2) ! top, bottom normal vector (outward) REAL (KIND=_RL90), INTENT( OUT ) :: dTop(2), dBot(2) ! vector pointing from top, bottom bdry to ray REAL (KIND=_RL90), INTENT( OUT ) :: DistTop, DistBot ! distance (normal to bdry) from the ray to top, bottom boundary - + dTop = rayx - Topx ! vector pointing from top to ray dBot = rayx - Botx ! vector pointing from bottom to ray DistTop = -DOT_PRODUCT( Topn, dTop ) DistBot = -DOT_PRODUCT( Botn, dBot ) - + RETURN END !SUBROUTINE Distances2D - + ! **********************************************************************! - + SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) USE bdry_mod, only: HSInfo USE refCoef, only: ReflectionCoef - + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER, INTENT( IN ) :: Npts ! unsued if there are no refcoef files REAL (KIND=_RL90), INTENT( IN ) :: tBdry(2), nBdry(2) ! Tangent and normal to the boundary @@ -806,7 +806,7 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) Refl ! for tabulated reflection coef. COMPLEX (KIND=_RL90) :: ch, a, b, d, sb, delta, ddelta ! for beam shift TYPE(ReflectionCoef) :: RInt - + !$TAF init reflect2d1 = 'bellhopreflectray2d' ! Init default values for local derived type Rint @@ -817,60 +817,60 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) ! increment stepping counters is = is + 1 ! old step is1 = is + 1 ! new step reflected (same x, updated basis vectors) - + Tg = DOT_PRODUCT( ray2D( is )%t, tBdry ) ! ray tan projected along boundary Th = DOT_PRODUCT( ray2D( is )%t, nBdry ) ! ray tan projected normal boundary - + ray2D( is1 )%NumTopBnc = ray2D( is )%NumTopBnc ray2D( is1 )%NumBotBnc = ray2D( is )%NumBotBnc ray2D( is1 )%x = ray2D( is )%x ray2D( is1 )%t = ray2D( is )%t - 2.0 * Th * nBdry ! change ray direction - + ! Calculate change in curvature, kappa ! Based on formulas given by Muller, Geoph. J. R.A.S., 79 (1984). - + ! Get c CALL evalSSP( ray2D( is )%x, c, cimag, gradc, crr, crz, czz, rho, myThid ) - + ! unmodified unit ray tangent and normal rayt = c * ray2D( is )%t ! unit tangent to ray rayn = [ -rayt( 2 ), rayt( 1 ) ] ! unit normal to ray - + ! reflected unit ray tangent and normal rayt_tilde = c * ray2D( is1 )%t ! unit tangent to ray rayn_tilde = -[ -rayt_tilde( 2 ), rayt_tilde( 1 ) ] ! unit normal to ray - - ! get the jumps (this could be simplified, e.g. jump in rayt is + + ! get the jumps (this could be simplified, e.g. jump in rayt is ! roughly 2 * Th * nbdry cnjump = -DOT_PRODUCT( gradc, rayn_tilde - rayn ) csjump = -DOT_PRODUCT( gradc, rayt_tilde - rayt ) RN = 2 * kappa / c ** 2 / Th ! boundary curvature correction - + IF ( BotTop == 'TOP' ) THEN - ! cnjump changes sign because the (t,n) system of the top boundary has a + ! cnjump changes sign because the (t,n) system of the top boundary has a ! different sense to the bottom boundary cnjump = -cnjump RN = -RN END IF - + RM = Tg / Th ! this is tan( alpha ) where alpha is the angle of incidence RN = RN + RM * ( 2 * cnjump - RM * csjump ) / c ** 2 - + SELECT CASE ( Beam%Type( 3 : 3 ) ) CASE ( 'D' ) RN = 2.0 * RN CASE ( 'Z' ) RN = 0.0 END SELECT - + ray2D( is1 )%c = c ray2D( is1 )%tau = ray2D( is )%tau ray2D( is1 )%p = ray2D( is )%p + ray2D( is )%q * RN ray2D( is1 )%q = ray2D( is )%q - + ! account for phase change - + SELECT CASE ( HS%BC ) CASE ( 'R' ) ! rigid ray2D( is1 )%Amp = ray2D( is )%Amp @@ -888,9 +888,9 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) CASE ( 'A', 'G' ) ! half-space kx = afreq * Tg ! wavenumber in direction parallel to bathymetry kz = afreq * Th ! wavenumber in direction perpendicular to bathymetry - + ! notation below is a bit mis-leading - ! kzS, kzP is really what I called gamma in other codes, and differs by a + ! kzS, kzP is really what I called gamma in other codes, and differs by a ! factor of +/- i IF ( REAL( HS%cS ) > 0.0 ) THEN kzS2 = kx**2 - ( afreq / HS%cS )**2 @@ -898,25 +898,25 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) kzS = SQRT( kzS2 ) kzP = SQRT( kzP2 ) mu = HS%rho * HS%cS**2 - + y2 = ( ( kzS2 + kx**2 )**2 - 4.0D0 * kzS * kzP * kx**2 ) * mu y4 = kzP * ( kx**2 - kzS2 ) - + f = afreq**2 * y4 g = y2 ELSE kzP = SQRT( kx**2 - ( afreq / HS%cP )**2 ) - - ! Intel and GFortran compilers return different branches of the SQRT + + ! Intel and GFortran compilers return different branches of the SQRT ! for negative reals IF ( REAL( kzP ) == 0.0D0 .AND. AIMAG( kzP ) < 0.0D0 ) kzP = -kzP f = kzP g = HS%rho ENDIF - + ! complex reflection coef. - Refl = - ( rho*f - i * kz*g ) / ( rho*f + i*kz*g ) - + Refl = - ( rho*f - i * kz*g ) / ( rho*f + i*kz*g ) + IF ( ABS( Refl ) < 1.0E-5 ) THEN ! kill a ray that has lost its energy in reflection ray2D( is1 )%Amp = 0.0 ray2D( is1 )%Phase = ray2D( is )%Phase @@ -924,39 +924,39 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) ray2D( is1 )%Amp = ABS( Refl ) * ray2D( is )%Amp ray2D( is1 )%Phase = ray2D( is )%Phase + & ATAN2( AIMAG( Refl ), REAL( Refl ) ) - + if ( Beam%Type( 4:4 ) == 'S' ) then ! beam displacement & width change (Seongil's version) ch = ray2D( is )%c / conjg( HS%cP ) co = ray2D( is )%t( 1 ) * ray2D( is )%c si = ray2D( is )%t( 2 ) * ray2D( is )%c ck = afreq / ray2D( is )%c - + a = 2 * HS%rho * ( 1 - ch * ch ) b = co * co - ch * ch d = HS%rho * HS%rho * si * si + b sb = sqrt( b ) cco = co * co ssi = si * si - + IF ( si /= 0.0 ) THEN delta = a * co / si / ( ck * sb * d ) ! Do we need an abs() on this??? ELSE delta = 0.0 END IF - + pdelta = real( delta ) / ( ray2D( is )%c / co) ddelta = -a / ( ck*sb*d ) - a*cco / ssi / (ck*sb*d) & + a*cco / (ck*b*sb*d) & -a*co / si / (ck*sb*d*d) & * (2* HS%rho * HS%rho *si*co-2*co*si) rddelta = -real( ddelta ) - sddelta = rddelta / abs( rddelta ) - - ! next 3 lines have an update by Diana McCammon to allow a sloping - ! bottom . I think the formulas are good, but this won't be reliable - ! because it doesn't have the logic that tracks crossing into new + sddelta = rddelta / abs( rddelta ) + + ! next 3 lines have an update by Diana McCammon to allow a sloping + ! bottom . I think the formulas are good, but this won't be reliable + ! because it doesn't have the logic that tracks crossing into new ! segments after the ray displacement. - + theta_bot = datan( tBdry( 2 ) / tBdry( 1 )) ! bottom angle ray2D( is1 )%x( 1 ) = ray2D( is1 )%x( 1 ) + real( delta ) & * dcos( theta_bot ) ! range displacement @@ -966,9 +966,9 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) ray2D( is1 )%q = ray2D( is1 )%q + sddelta * rddelta * si * c & * ray2D( is )%p ! beam-width change endif - + ENDIF - + CASE DEFAULT #ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(2A)') 'HS%BC = ', HS%BC @@ -980,7 +980,7 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R Reflect2D' END SELECT - + ! Update top/bottom bounce counter IF (BotTop == 'TOP') THEN ray2D( is+1 )%NumTopBnc = ray2D( is )%NumTopBnc + 1 @@ -988,14 +988,14 @@ SUBROUTINE Reflect2D( is, HS, BotTop, tBdry, nBdry, kappa, RefC, Npts, myThid ) ray2D( is+1 )%NumBotBnc = ray2D( is )%NumBotBnc + 1 ELSE #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'BELLHOP Reflect2D: ', & + WRITE(msgBuf,'(2A)') 'BELLHOP Reflect2D: ', & 'no reflection bounce, but in relfect2d somehow' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R Reflect2D' END IF - + RETURN END !SUBROUTINE Reflect2D - + END MODULE BELLHOP diff --git a/src/chen_millero.F b/src/chen_millero.F index 87c5ae7..a8c4ff0 100644 --- a/src/chen_millero.F +++ b/src/chen_millero.F @@ -16,7 +16,7 @@ _RL FUNCTION CHEN_MILLERO(i,j,k,bi,bj, C | the model setup specific EOS. C | C | o Reference: -C | C. Chen and F. J. Millero, "Speed of sound in seawater at +C | C. Chen and F. J. Millero, "Speed of sound in seawater at C | high pressures," C | J. Acoust. Soc. Am. 672.5, 1129-1135 (1977). C *==========================================================* @@ -37,7 +37,7 @@ _RL FUNCTION CHEN_MILLERO(i,j,k,bi,bj, C myThid :: Thread number for this instance of the routine. INTEGER myThid -#ifdef ALLOW_IHOP +#ifdef ALLOW_IHOP C !FUNCTIONS: _RL SW_TEMP EXTERNAL SW_TEMP @@ -82,33 +82,33 @@ _RL FUNCTION CHEN_MILLERO(i,j,k,bi,bj, C convert pressure to bar for Chen and Millero algorithm pres = pres/(1. _d 1) cw = c0 + 5.0383 _d 0*temp + - & -5.81090 _d -2*temp**2 + 3.3432 _d -4*temp**3 + + & -5.81090 _d -2*temp**2 + 3.3432 _d -4*temp**3 + & -1.47797 _d -6*temp**4 + 3.1419 _d -9*temp**5 + & (1.53563 _d -1 + 6.8999 _d -4*temp + & -8.1829 _d -6*temp**2 + 1.3632 _d -7*temp**3 + - & -6.1260 _d -10*temp**4)*pres + + & -6.1260 _d -10*temp**4)*pres + & (3.12600 _d -5 - 1.7111 _d -6*temp + & 2.59860 _d -8*temp**2 - 2.5353 _d -10*temp**3 + & 1.04150 _d -12*temp**4)*pres**2 + - & (-9.7729 _d -9 + 3.8513 _d -10*temp + + & (-9.7729 _d -9 + 3.8513 _d -10*temp + & -2.3654 _d -12*temp**2)*pres**3 - a = 1.389 _d 0 - 1.2620 _d -2*temp + + a = 1.389 _d 0 - 1.2620 _d -2*temp + & 7.166 _d -5*temp**2 + 2.0080 _d -6*temp**3 + & -3.21 _d -8*temp**4 + & (9.47420 _d -5 - 1.2583 _d -5*temp + & -6.4928 _d -8*temp**2 + 1.0515 _d -8*temp**3 + & -2.0142 _d -10*temp**4)*pres + & (-3.9064 _d -7 + 9.1061 _d -9*temp + - & -1.6009 _d -10*temp**2 + + & -1.6009 _d -10*temp**2 + & 7.99400 _d -12*temp**3)*pres**2 + & (1.10000 _d -10 + 6.6510 _d -12*temp + & -3.3910 _d -13*temp**2)*pres**3 - b = -1.9220 _d -2 - 4.4200 _d -5*temp + + b = -1.9220 _d -2 - 4.4200 _d -5*temp + & (7.3637 _d -5 + 1.7950 _d -7*temp)*pres - d = 1.727 _d -3 - 7.9836 _d -6*pres + d = 1.727 _d -3 - 7.9836 _d -6*pres CHEN_MILLERO = cw + a*sal + b*sal**(3./2.) + d*sal**2 -#endif /* ALLOW_IHOP */ +#endif /* ALLOW_IHOP */ RETURN END diff --git a/src/cost_ihop.F b/src/cost_ihop.F index 09647c6..1e9aec7 100644 --- a/src/cost_ihop.F +++ b/src/cost_ihop.F @@ -47,7 +47,7 @@ SUBROUTINE COST_IHOP( # include "tamc.h" #endif -C !INPUT PARAMETERS: +C !INPUT PARAMETERS: C myTime :: Current time in simulation C myIter :: Current time-step number C myThid :: my Thread Id number @@ -84,7 +84,7 @@ SUBROUTINE COST_IHOP( _RL ihopObs_modval_glob(NOBSMAX_IHOP) _RL samples_mask_glob(NOBSMAX_IHOP) #endif - + C !FUNCTIONS INTEGER ILNBLNK EXTERNAL ILNBLNK @@ -106,7 +106,7 @@ SUBROUTINE COST_IHOP( #ifdef ALLOW_COST JL = ILNBLNK( ihopObsDir ) - + DO num_file=1,NFILESMAX_IHOP ! Init default buffer values DO m=1,NOBSMAX_IHOP @@ -139,7 +139,7 @@ SUBROUTINE COST_IHOP( ENDDO !bi ENDDO !bj - + DO bj=1,nSy DO bi=1,nSx @@ -162,16 +162,16 @@ SUBROUTINE COST_IHOP( ENDIF !if (m.LE.ObsNo_tiled(num_file,bi,bj)) then ENDDO !do m=.. - + ENDDO !bj ENDDO !bi C Combine MPI processes DO ii=1,NOBSMAX_IHOP tmpgs = ihopObs_buff(ii) - _GLOBAL_SUM_RL(tmpgs, myThid) + _GLOBAL_SUM_RL(tmpgs, myThid) ihopObs_modval_glob(ii) = tmpgs - ENDDO + ENDDO IF ( myProcId .eq. 0 ) THEN C Loop over global obs @@ -183,7 +183,7 @@ SUBROUTINE COST_IHOP( C Extract model equi: Keep in case you want NP avg in future dev ihop_modval = ihop_modval + ihopObs_modval_glob(m) - + c Write to global netcdf file CALL active_write_ihop_glob(num_file, & ihop_modval, @@ -203,7 +203,7 @@ SUBROUTINE COST_IHOP( & ihopObsDir(1:JL),ihopObsFile(1:IL),'.equi.nc' err = NF_OPEN(fnameequinc,NF_NOWRITE,fidglobal(num_file)) cc ENDIF - + C Loop over global obs DO m=1,NOBSMAX_IHOP IF (m.LE.ObsNo(num_file)) THEN @@ -245,7 +245,7 @@ SUBROUTINE COST_IHOP( ENDIF !if myprocid = 0 ENDDO !do num_file=1,NFILESMAX_IHOP - + #endif /* ALLOW_COST */ _END_MASTER( myThid ) diff --git a/src/ihop_ad.flow b/src/ihop_ad.flow index 3f549d8..ebe4481 100644 --- a/src/ihop_ad.flow +++ b/src/ihop_ad.flow @@ -22,7 +22,7 @@ !$TAF SUBROUTINE arr_mod::writearrivalsbinary OUTPUT = !$TAF SUBROUTINE ihop_init_diag::openOutputFiles INPUT = 1, 2, 3, 4 -!$TAF SUBROUTINE ihop_init_diag::openOutputFiles OUTPUT = +!$TAF SUBROUTINE ihop_init_diag::openOutputFiles OUTPUT = ! *==========================================================* ! | SUBROUTINE READSSP is passive | @@ -60,7 +60,7 @@ ! | SUBROUTINE COMPUTEBDRYTANGENTNORMAL is passive | ! *==========================================================* !$TAF SUBROUTINE bdry_mod::initati INPUT = 1, 2, 3 -!$TAF SUBROUTINE bdry_mod::initati OUTPUT = +!$TAF SUBROUTINE bdry_mod::initati OUTPUT = !$TAF SUBROUTINE bdry_mod::initati MODULE bdry_mod OUTPUT = top !$TAF SUBROUTINE bdry_mod::initbty INPUT = 1, 2, 3 @@ -91,12 +91,12 @@ ! *==========================================================* !$TAF SUBROUTINE srpos_mod::readvector INPUT = 1, 2, 3, 4, 5 !$TAF SUBROUTINE srpos_mod::readvector OUTPUT = 2 -!$TAF SUBROUTINE srpos_mod::readvector DEPEND = 1 +!$TAF SUBROUTINE srpos_mod::readvector DEPEND = 1 !$TAF SUBROUTINE srpos_mod::readvector MODULE sort_mod INPUT = sort !$TAF SUBROUTINE srpos_mod::readvector MODULE subtab_mod INPUT = subtab !$TAF SUBROUTINE srpos_mod::readfreqvec INPUT = 1, 2 -!$TAF SUBROUTINE srpos_mod::readfreqvec OUTPUT = +!$TAF SUBROUTINE srpos_mod::readfreqvec OUTPUT = !$TAF SUBROUTINE srpos_mod::readfreqvec MODULE subtab_mod INPUT = subtab !================================================================* @@ -107,8 +107,8 @@ ! | SUBROUTINE IHOP_COST_READ_OBS is passive | ! *==========================================================* !$TAF SUBROUTINE ihop_cost_read_obs INPUT = 1,2,3, 5 -!$TAF SUBROUTINE ihop_cost_read_obs DEPEND = 1,2,3 -!$TAF SUBROUTINE ihop_cost_read_obs OUTPUT = 4 +!$TAF SUBROUTINE ihop_cost_read_obs DEPEND = 1,2,3 +!$TAF SUBROUTINE ihop_cost_read_obs OUTPUT = 4 -!$TAF SUBROUTINE NF_OPEN INPUT = +!$TAF SUBROUTINE NF_OPEN INPUT = !$TAF SUBROUTINE NF_CLOSE INPUT = diff --git a/src/ihop_cost_init_equifiles.F b/src/ihop_cost_init_equifiles.F index 22393b4..3a2a55d 100644 --- a/src/ihop_cost_init_equifiles.F +++ b/src/ihop_cost_init_equifiles.F @@ -3,8 +3,8 @@ CBOP C !ROUTINE: IHOP_COST_INIT_EQUIFILES -C !INTERFACE: - SUBROUTINE IHOP_COST_INIT_EQUIFILES( +C !INTERFACE: + SUBROUTINE IHOP_COST_INIT_EQUIFILES( I num_file, I fid1, I file2, @@ -15,8 +15,8 @@ SUBROUTINE IHOP_COST_INIT_EQUIFILES( I myThid ) C !DESCRIPTION: -C Initialization of model counterparts files -C for ihop obs data +C Initialization of model counterparts files +C for ihop obs data C !USES: IMPLICIT NONE diff --git a/src/ihop_cost_init_fixed.F b/src/ihop_cost_init_fixed.F index 64e244c..bc9bf9a 100644 --- a/src/ihop_cost_init_fixed.F +++ b/src/ihop_cost_init_fixed.F @@ -65,7 +65,7 @@ subroutine ihop_cost_init_fixed( myThid ) INTEGER :: varid1a, varid1b, varid2, varid3 INTEGER :: varid4a, varid4b, varid4c integeR :: varid5a, varid5b, varidEquiv(2) - INTEGER :: weighIhopObs, obsIsInRunTime + INTEGER :: weighIhopObs, obsIsInRunTime INTEGER :: ObsNo_valid, ihopObsInTile INTEGER :: tmpdate(4), tmpdiff(4) INTEGER :: num_file, hh, obsno_hh @@ -133,7 +133,7 @@ subroutine ihop_cost_init_fixed( myThid ) IF (IL.NE.0) THEN !=========================================================== -! READ IHOP OBS NETCDF IDs +! READ IHOP OBS NETCDF IDs !=========================================================== WRITE(fnamedatanc,'(2A)') ihopObsFile(1:IL),'.nc' @@ -143,7 +143,7 @@ subroutine ihop_cost_init_fixed( myThid ) ncid = fiddata_obs(num_file) err = NF_INQ_DIMID(ncid,'iOBS', dimid1 ) err = NF_INQ_DIMLEN(ncid, dimid1, obsNo(num_file) ) - + WRITE(msgbuf,'(A,I9)') & ' # of observations in file =', & obsNo(num_file) @@ -211,7 +211,7 @@ subroutine ihop_cost_init_fixed( myThid ) ihop_nameval = 'ihop_val' ihop_nameuncert = 'ihop_uncert' -! Create netcdf global file for ihop model equivalent +! Create netcdf global file for ihop model equivalent IF ( myProcId .eq. 0 ) THEN JL = ILNBLNK( ihopObsDir ) @@ -279,11 +279,11 @@ subroutine ihop_cost_init_fixed( myThid ) err = NF_ENDDEF(fidadglobal(num_file)) err = NF_CLOSE(fidadglobal(num_file)) - err = NF_OPEN(adfnameequincglo, NF_WRITE, + err = NF_OPEN(adfnameequincglo, NF_WRITE, & fidadglobal(num_file)) ELSE - err = NF_OPEN(adfnameequincglo, NF_WRITE, + err = NF_OPEN(adfnameequincglo, NF_WRITE, & fidadglobal(num_file)) ENDIF #endif @@ -317,8 +317,8 @@ subroutine ihop_cost_init_fixed( myThid ) ! loop through number of observations, in obsfit this is a 'chunk' DO m=1,ObsNo(num_file) -!AV if obs starts before model run, will be ignored even if it ends after -!AV model starts - ok for now +!AV if obs starts before model run, will be ignored even if it ends after +!AV model starts - ok for now IF (( ( tmpyymmdd(m).GT.yymmddMin ).OR.(( tmpyymmdd(m).EQ. & yymmddMin ).AND.( tmphhmmss(m).GE.hhmmssMin ))).AND. & ( ( tmpyymmdd(m).LT.yymmddMax ).OR.(( tmpyymmdd(m).EQ. @@ -352,7 +352,7 @@ subroutine ihop_cost_init_fixed( myThid ) ENDIF !if (obsIsInRunTime.EQ.1) then -! regardless of whether obs is in run time or not, +! regardless of whether obs is in run time or not, ! keep track of ihop obs index position ! and assign time to ihop obs tmp_ihopObs_time(m)=diffsecs @@ -400,7 +400,7 @@ subroutine ihop_cost_init_fixed( myThid ) ENDDO !k ! Read ALL info using respective varid and save to tmp, NO CHUNKS! - IF (weighIhopObs.EQ.1) THEN + IF (weighIhopObs.EQ.1) THEN err = NF_GET_VARA_DOUBLE(ncid,varid3,1, & ObsNo_tiled(num_file,bi,bj), tmp_uncert2) ENDIF @@ -422,7 +422,7 @@ subroutine ihop_cost_init_fixed( myThid ) ! loop through observations, NOTE: in obsfit this is a 'chunk' DO m=1,ObsNo_tiled(num_file,bi,bj) ihopObsInTile=1 - + ! in a valid time? IF ((tmp_ihopObs_time(m).LT.0. _d 0) .OR. & (tmp_ihopObs_time(m).GT. modelend-modelstart)) THEN @@ -445,19 +445,19 @@ subroutine ihop_cost_init_fixed( myThid ) & (tmp_lon.GT.lon_cur).AND. & (yC(1,1,bi,bj).LE.lat_cur).AND. & (yC(1,sNy+1,bi,bj).GT.lat_cur) ) THEN -! do nothing +! do nothing ELSEIF ((xC(sNx+1,1,bi,bj).LT.xC(1,1,bi,bj)).AND. & (xC(1,1,bi,bj).LE.lon_cur+360. _d 0).AND. & (tmp_lon.GT.lon_cur+360. _d 0).AND. & (yC(1,1,bi,bj).LE.lat_cur).AND. & (yC(1,sNy+1,bi,bj).GT.lat_cur) & ) THEN - lon_cur=lon_cur+360. _d 0 + lon_cur=lon_cur+360. _d 0 ELSE ! not in this tile ihopObsInTile=0 ENDIF - + ! Determine i,j,k to the south-west-down of obs datum ! set default values ihopObs_i=-10 @@ -504,7 +504,7 @@ subroutine ihop_cost_init_fixed( myThid ) lon_tmp2=xC(i+1,j,bi,bj) lat_tmp1=yC(i,j,bi,bj) lat_tmp2=yC(i,j+1,bi,bj) - + ! value of j, south of the obs datum: IF ((lat_tmp1.LE.lat_cur).AND. & (lat_tmp2.GT.lat_cur)) THEN @@ -544,7 +544,7 @@ subroutine ihop_cost_init_fixed( myThid ) ihopObs_time(num_file,ObsNo_valid,bi,bj) = & tmp_ihopObs_time(m) - IF (weighIhopObs.EQ.1) THEN + IF (weighIhopObs.EQ.1) THEN ihopObs_uncert(num_file,ObsNo_valid,bi,bj)=tmp_uncert2(m) ENDIF ihopObs_lon(num_file,ObsNo_valid,bi,bj)=lon_cur @@ -572,7 +572,7 @@ subroutine ihop_cost_init_fixed( myThid ) ! Number of valid ihop obs in the file ObsNo_tiled(num_file,bi,bj) = ObsNo_valid - + WRITE(msgbuf,'(A,I4,A,I4)') & ' current tile is bi,bj =', & bi,',',bj @@ -653,7 +653,7 @@ subroutine ihop_cost_init_fixed( myThid ) ENDIF !if (IL.NE.0) then ENDDO ! do num_file=1,NFILESMAX_IHOP - + _END_MASTER( myThid ) _BARRIER @@ -676,7 +676,7 @@ subroutine ihop_cost_init_fixed( myThid ) WRITE(msgbuf,'(A)') ' ' CALL print_message( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, myThid) - + #endif /* ALLOW_COST && ALLOW_IHOP*/ RETURN diff --git a/src/ihop_cost_inloop.F b/src/ihop_cost_inloop.F index cc0c6a8..faf7e56 100644 --- a/src/ihop_cost_inloop.F +++ b/src/ihop_cost_inloop.F @@ -41,7 +41,7 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) # include "tamc.h" #endif -C !INPUT PARAMETERS: +C !INPUT PARAMETERS: C myTime :: Current time in simulation C myThid :: my Thread Id number _RL myTime @@ -49,7 +49,7 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) CEOP #ifdef ALLOW_IHOP -C !LOCAL VARIABLES: +C !LOCAL VARIABLES: INTEGER m,k,bi,bj,num_file,varid1,err INTEGER maxindex(Nrr, Nrd) _RL ihop_modval @@ -84,7 +84,7 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) IF (m.LE.ObsNo_tiled(num_file,bi,bj)) THEN IF ((ihopObs_time(num_file,m,bi,bj).GE.myTime) - & .AND.(ihopObs_time(num_file,m,bi,bj).LT. + & .AND.(ihopObs_time(num_file,m,bi,bj).LT. & (myTime+deltaTclock))) THEN !!ADJ STORE ihop_modval = comlev1_bibj, key=itdkey, kind=isbyte @@ -93,8 +93,8 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) CALL ihop_cost_modval(ihop_modval, num_file, & 1, 1, myTime, myThid) - -! err = NF_INQ_VARID(fidfwd_obs(num_file,bi,bj),ihop_nameequi, + +! err = NF_INQ_VARID(fidfwd_obs(num_file,bi,bj),ihop_nameequi, ! & varid1) ! err = NF_PUT_VARA_DOUBLE(fidfwd_obs(num_file,bi,bj), varid1, ! & m, 1, ihop_modval) @@ -106,7 +106,7 @@ SUBROUTINE IHOP_COST_INLOOP( myTime, myThid ) ENDIF !if (ObsNo_tiled(num_file,bi,bj).NE.0) then ENDDO !do m... ENDDO !do num_file=1,NFILESMAX_OBS - + ENDDO ENDDO diff --git a/src/ihop_cost_modval.F b/src/ihop_cost_modval.F index 0a44c94..af1143e 100644 --- a/src/ihop_cost_modval.F +++ b/src/ihop_cost_modval.F @@ -11,11 +11,11 @@ C !INTERFACE: ========================================================== SUBROUTINE IHOP_COST_MODVAL( - O modval, + O modval, I num_file, ri, rj, myTime, myThid ) C !DESCRIPTION: -C Computes ihop predicted datum +C Computes ihop predicted datum C !FORTRAN90 USE MODULES: =============================================== USE arr_mod, only: Arr, Narr, MaxNArr @@ -48,7 +48,7 @@ SUBROUTINE IHOP_COST_MODVAL( # include "tamc.h" #endif -C !INPUT PARAMETERS: +C !INPUT PARAMETERS: C myTime :: Current time in simulation C myThid :: my Thread Id number _RL myTime @@ -57,7 +57,7 @@ SUBROUTINE IHOP_COST_MODVAL( CEOP #ifdef ALLOW_IHOP -C !LOCAL VARIABLES: +C !LOCAL VARIABLES: INTEGER ri,rj INTEGER ii,j INTEGER k,num_file @@ -81,14 +81,14 @@ SUBROUTINE IHOP_COST_MODVAL( ! are ri and rj contained in Nrr AND Nrd IF ( (ri.GT.Nrr).and.(rj.gt.Nrd) ) THEN WRITE(msgBuf,'(3A)') - & 'IHOP_COST_MODVAL:', + & 'IHOP_COST_MODVAL:', & ' receiver range and depth ID larger than Nrr and Nrd.' CALL PRINT_ERROR( msgBuf, myThid) ENDIF ! Calc Arrival Amplitude with cylindrical spreading to receiver range DO ii=1,Narr(ri,rj) - arrival_amplitude(ii) = Arr(ii,ri,rj)%A / sqrt(pos%rr(ri)) + arrival_amplitude(ii) = Arr(ii,ri,rj)%A / sqrt(pos%rr(ri)) & * exp(cmplx(0,1)*rad2deg*Arr(ii,ri,rj)%Phase) arrval(ii) = ABS( arrival_amplitude(ii) ) diff --git a/src/ihop_cost_read_obs.F b/src/ihop_cost_read_obs.F index c8cd12c..3a2d9ec 100644 --- a/src/ihop_cost_read_obs.F +++ b/src/ihop_cost_read_obs.F @@ -7,14 +7,14 @@ C !INTERFACE: SUBROUTINE IHOP_COST_READ_OBS( - I fNb, - I vNb, + I fNb, + I vNb, I irec, O vec_loc, I myThid ) C !DESCRIPTION: -C Reads an observation and its uncertainty from a netcdf ihop +C Reads an observation and its uncertainty from a netcdf ihop C input file C !USES: @@ -35,10 +35,10 @@ SUBROUTINE IHOP_COST_READ_OBS( #endif C !INPUT/OUTPUT PARAMETERS: -C fNb, vNb :: -C irec :: +C fNb, vNb :: +C irec :: C myThid :: my Thread Id number -C vec_loc :: +C vec_loc :: INTEGER fNb, vNb INTEGER irec, myThid _RL vec_loc diff --git a/src/ihop_ini_io.F b/src/ihop_ini_io.F index dd689b2..5648cba 100644 --- a/src/ihop_ini_io.F +++ b/src/ihop_ini_io.F @@ -3,13 +3,13 @@ CBOP C !ROUTINE: IHOP_INI_IO -C !INTERFACE: +C !INTERFACE: SUBROUTINE IHOP_INI_IO( myThid ) C !DESCRIPTION: C Create directory for ihop output if needed -C !USES: +C !USES: IMPLICIT NONE C == Global variables === #include "SIZE.h" @@ -23,7 +23,7 @@ SUBROUTINE IHOP_INI_IO( myThid ) #endif -C !INPUT PARAMETERS: +C !INPUT PARAMETERS: C myThid :: my Thread Id number INTEGER myThid @@ -33,7 +33,7 @@ SUBROUTINE IHOP_INI_IO( myThid ) CEOP #if (defined ALLOW_IHOP) && (defined ALLOW_COST) -C !LOCAL VARIABLES: +C !LOCAL VARIABLES: #ifndef HAVE_SYSTEM CHARACTER*(MAX_LEN_MBUF) msgBuf #endif diff --git a/src/ihop_init_diag.F90 b/src/ihop_init_diag.F90 index 72a05a9..7f6f3f2 100644 --- a/src/ihop_init_diag.F90 +++ b/src/ihop_init_diag.F90 @@ -43,7 +43,7 @@ MODULE IHOP_INIT_DIAG SUBROUTINE initPRTFile( myTime, myIter, myThid ) USE ihop_mod, only: PRTFile, Beam USE angle_mod, only: Angles - USE srpos_mod, only: WriteSxSy, WriteSzRz, WriteRcvrRanges, WriteFreqVec + USE srpos_mod, only: WriteSxSy, WriteSzRz, WriteRcvrRanges, WriteFreqVec ! I/O routine for acoustic fixed inputS @@ -55,14 +55,14 @@ SUBROUTINE initPRTFile( myTime, myIter, myThid ) _RL, INTENT(IN) :: myTime INTEGER, INTENT(IN) :: myIter, myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == - INTEGER, PARAMETER :: Number_to_Echo = 10 + INTEGER, PARAMETER :: Number_to_Echo = 10 ! REAL (KIND=_RL90), PARAMETER :: c0 = 1500.0 ! REAL (KIND=_RL90) :: x(2), c, cimag, gradc(2), crz, czz, rho, Depth - REAL (KIND=_RL90) :: ranges + REAL (KIND=_RL90) :: ranges ! CHARACTER (LEN=10) :: PlotType - + ! *** ihop info to PRTFile *** CALL openPRTFile( myTime, myIter, myThid ) @@ -73,21 +73,21 @@ SUBROUTINE initPRTFile( myTime, myIter, myThid ) ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN CALL WriteRunType( Beam%RunType, myThid ) - + CALL WriteTopOpt( myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A,F10.2,A)' ) 'Depth = ',Bdry%Bot%HS%Depth,' m' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)') 'Top options: ', Bdry%Top%HS%Opt CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) CALL WriteTopBot( Bdry%Top%HS, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)') 'Bottom options: ', Bdry%Bot%HS%Opt CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -139,17 +139,17 @@ SUBROUTINE initPRTFile( myTime, myIter, myThid ) CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END IF - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)')'______________________________________________', & '_____________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A,G11.4,A)') & ' Step length, deltas = ', Beam%deltas, ' m' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) #ifdef IHOP_THREED @@ -204,7 +204,7 @@ SUBROUTINE WriteTopOpt( myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN= 1) :: BC ! Boundary condition type @@ -214,7 +214,7 @@ SUBROUTINE WriteTopOpt( myThid ) IF (IHOP_dumpfreq.LT.0) RETURN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Interior options: ' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -333,7 +333,7 @@ SUBROUTINE WriteRunType( RunType, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER*(7), INTENT( IN ) :: RunType @@ -341,7 +341,7 @@ SUBROUTINE WriteRunType( RunType, myThid ) IF (IHOP_dumpfreq.LT.0) RETURN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) SELECT CASE ( RunType( 1:1 ) ) @@ -448,7 +448,7 @@ SUBROUTINE WriteTopBot( HS, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == TYPE ( HSInfo ), INTENT( IN ) :: HS REAL (KIND=_RL90) :: Mz ! values related to grain size @@ -468,7 +468,7 @@ SUBROUTINE WriteTopBot( HS, myThid ) CASE ( 'A' ) WRITE(msgBuf,'(A)') ' ACOUSTO-ELASTIC half-space' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') & ' z [m] alphaR [m/s] betaR rho [g/cm^3] alphaI betaI' @@ -479,7 +479,7 @@ SUBROUTINE WriteTopBot( HS, myThid ) CASE ( 'G' ) ! *** Grain size (formulas from UW-APL HF Handbook) WRITE(msgBuf,'(A)') ' Grain size to define half-space' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'( F10.2, 3X, F10.2 )' ) HS%Depth, Mz CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -684,7 +684,7 @@ SUBROUTINE OpenOutputFiles( fName, myTime, myIter, myThid ) CASE DEFAULT atten = 0.0 - ! following to set PlotType has alread been done in READIN if that was + ! following to set PlotType has alread been done in READIN if that was ! used for input SELECT CASE ( Beam%RunType( 5 : 5 ) ) CASE ( 'R' ) @@ -714,7 +714,7 @@ SUBROUTINE WriteSHDHeader( FileName, Title, freq0, Atten, PlotType ) REAL, INTENT( IN ) :: freq0, Atten ! Nominal frequency, stabilizing attenuation (for wavenumber integration only) CHARACTER, INTENT( IN ) :: FileName*( * ) ! Name of the file (could be a shade file or a Green's function file) CHARACTER, INTENT( IN ) :: Title*( * ) ! Arbitrary title - CHARACTER, INTENT( IN ) :: PlotType*( 10 ) ! + CHARACTER, INTENT( IN ) :: PlotType*( 10 ) ! INTEGER :: LRecl ! receiver bearing angles @@ -742,13 +742,13 @@ SUBROUTINE WriteSHDHeader( FileName, Title, freq0, Atten, PlotType ) ! MAX( 41, ... ) below because Title is already 40 words (or 80 bytes) ! words/record (NRr doubled for complex pressure storage) LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz, & - Pos%NRz, 2 * Pos%NRr ) + Pos%NRz, 2 * Pos%NRr ) OPEN ( FILE = FileName, UNIT = SHDFile, STATUS = 'REPLACE', & ACCESS = 'DIRECT', RECL = 4 * LRecl, FORM = 'UNFORMATTED') WRITE( SHDFile, REC = 1 ) LRecl, Title( 1 : 80 ) WRITE( SHDFile, REC = 2 ) PlotType - WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& + WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& Pos%NRz, Pos%NRr, freq0, atten WRITE( SHDFile, REC = 4 ) freqVec( 1 : Nfreq ) WRITE( SHDFile, REC = 5 ) Pos%theta( 1 : Pos%Ntheta ) @@ -762,13 +762,13 @@ SUBROUTINE WriteSHDHeader( FileName, Title, freq0, Atten, PlotType ) ELSE ! compressed format for TL from FIELD3D ! words/record (NR doubled for complex pressure storage) - LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSz, Pos%NRz, 2 * Pos%NRr ) + LRecl = MAX( 41, 2 * Nfreq, Pos%Ntheta, Pos%NSz, Pos%NRz, 2 * Pos%NRr ) OPEN ( FILE = FileName, UNIT = SHDFile, STATUS = 'REPLACE', & ACCESS = 'DIRECT', RECL = 4 * LRecl, FORM = 'UNFORMATTED') WRITE( SHDFile, REC = 1 ) LRecl, Title( 1 : 80 ) WRITE( SHDFile, REC = 2 ) PlotType - WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& + WRITE( SHDFile, REC = 3 ) Nfreq, Pos%Ntheta, Pos%NSx, Pos%NSy, Pos%NSz,& Pos%NRz, Pos%NRr, freq0, atten WRITE( SHDFile, REC = 4 ) freqVec( 1 : Nfreq ) WRITE( SHDFile, REC = 5 ) Pos%theta( 1 : Pos%Ntheta ) @@ -810,7 +810,7 @@ SUBROUTINE AllocatePos( Nx, x_out, x_in ) ! Allocate and populate Pos structure from data.ihop - INTEGER, INTENT( IN ) :: Nx + INTEGER, INTENT( IN ) :: Nx REAL(KIND=_RL90), INTENT( IN ) :: x_in(:) REAL(KIND=_RL90), ALLOCATABLE, INTENT( OUT ) :: x_out(:) INTEGER :: i @@ -911,13 +911,13 @@ SUBROUTINE openPRTFile ( myTime, myIter, myThid ) #ifdef IHOP_WRITE_OUT WRITE(msgbuf,'(A)') 'iHOP Print File' CALL PRINT_MESSAGE( msgBuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgbuf,'(A)') + WRITE(msgbuf,'(A)') CALL PRINT_MESSAGE( msgBuf, PRTFile, SQUEEZE_RIGHT, myThid ) #endif /* IHOP_WRITE_OUT */ ! *** TITLE *** #ifdef IHOP_THREED - WRITE(msgBuf,'(2A)') 'IHOP_INIT_DIAG openPRTFile: ', & + WRITE(msgBuf,'(2A)') 'IHOP_INIT_DIAG openPRTFile: ', & '3D not supported in ihop' CALL PRINT_ERROR( msgBuf,myThid ) STOP 'ABNORMAL END: S/R openPRTFile' @@ -968,7 +968,7 @@ SUBROUTINE resetMemory() USE angle_mod, only: Angles USE arr_mod, only: Narr, Arr, U USE ihop_mod, only: ray2D, MaxN, iStep - + ! From bdry_mod IF (ALLOCATED(Top)) DEALLOCATE(Top) IF (ALLOCATED(Bot)) DEALLOCATE(Bot) diff --git a/src/ihop_init_fixed.F b/src/ihop_init_fixed.F index 038662b..1f9961f 100644 --- a/src/ihop_init_fixed.F +++ b/src/ihop_init_fixed.F @@ -53,7 +53,7 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| C Only do I/O if in the main thread _BEGIN_MASTER( myThid ) - + C Read NetCDF input: setting the acoustic domain IL = ILNBLNK( IHOP_interpfile ) IF (IL.NE.0) THEN @@ -76,7 +76,7 @@ SUBROUTINE IHOP_INIT_FIXED( myThid ) err = NF_INQ_DIMID( ncid, 'nidw', dimid2 ) err = NF_INQ_DIMLEN( ncid, dimid2, IHOP_npts_idw ) - IF ( IHOP_npts_range>IHOP_MAX_NC_SIZE .OR. + IF ( IHOP_npts_range>IHOP_MAX_NC_SIZE .OR. & IHOP_npts_idw>IHOP_MAX_NC_SIZE ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_INIT_FIXED: reading dims', & 'NetCDF Dimensions exceed maximum allowable size' diff --git a/src/ihop_init_mod.F90 b/src/ihop_init_mod.F90 index 2261223..7d2063c 100644 --- a/src/ihop_init_mod.F90 +++ b/src/ihop_init_mod.F90 @@ -43,13 +43,13 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) REAL (KIND=_RL90) :: x(2), Depth !! !! ! =========================================================================== - + !IESCO24: some notes while I noodle - ! Use data.ihop, set time series invariant parameters. These are fixed + ! Use data.ihop, set time series invariant parameters. These are fixed ! parameters that do not depend on which time step you run ihop in. ! Primarily, the parameters are related to the acoustic grid: ! - From initenvihop.F90:initEnv - ! - Bdry%Top, Bdry%Bot, + ! - Bdry%Top, Bdry%Bot, ! SSP%AttenUnit,Type,Nr,Nz,z,SSP%Seg%r, ! Pos%Sx,Sy,Nsz,Nrz,Sz,Rz,Ws,Isz,Wr,Irz,Nrr,Rr,Delta_r, ! Beam%RunType,Deltas,Nimage,iBeamWindow,Component,Multiplier,rloop, @@ -59,7 +59,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! - Top%Natipts,x, ! - From bdry_mod.F90:initBTY ! - Bot%Natipts,x, - ! This subroutine will set parameters that shouldn't need to be modified + ! This subroutine will set parameters that shouldn't need to be modified ! throughout the MITgcm model run ! === Set local parameters === @@ -73,8 +73,8 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) Pos%NSy = -1 Pos%NSz = -1 Pos%NRz = -1 - Pos%NRr = -1 - Pos%Ntheta = -1 + Pos%NRr = -1 + Pos%Ntheta = -1 Pos%Delta_r = -999. Pos%Delta_theta = -999. @@ -115,17 +115,17 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! *** Bottom Boundary *** - Bdry%Bot%HS%Opt = IHOP_botopt + Bdry%Bot%HS%Opt = IHOP_botopt IF ( IHOP_depth.NE.0 ) THEN Bdry%Bot%HS%Depth = IHOP_depth ELSE ! Extend by 5 wavelengths - Bdry%Bot%HS%Depth = rkSign*rF( Nr+1 ) + 5*c0/IHOP_freq + Bdry%Bot%HS%Depth = rkSign*rF( Nr+1 ) + 5*c0/IHOP_freq END IF Bdry%Bot%HS%BC = Bdry%Bot%HS%Opt( 1:1 ) CALL TopBot( AttenUnit, Bdry%Bot%HS, myThid ) - + SELECT CASE ( Bdry%Bot%HS%Opt( 2:2 ) ) CASE( '~', '*', ' ' ) CASE DEFAULT @@ -183,10 +183,10 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! *** Acoustic grid *** ! Step size in meters [m] Beam%deltas = IHOP_step - + ! Automatic step size option - IF ( Beam%deltas == 0.0 ) THEN - Beam%deltas = ( Depth ) / 10. + IF ( Beam%deltas == 0.0 ) THEN + Beam%deltas = ( Depth ) / 10. END IF ! Domain size @@ -200,7 +200,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! don't worry about the beam type if this is a ray trace run ! IESCO23: using 'e' requires Beam%Type to be set - IF ( Beam%RunType( 1:1 ) /= 'R' .OR. Beam%RunType( 1:1 ) /= 'E' ) THEN + IF ( Beam%RunType( 1:1 ) /= 'R' .OR. Beam%RunType( 1:1 ) /= 'E' ) THEN ! Beam%Type( 1 : 1 ) is ! 'G' or '^' Geometric hat beams in Cartesian coordinates @@ -216,7 +216,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! 'D' Double ! 'S' Single ! 'Z' Zero - ! Beam%Type( 4 : 4 ) selects whether beam shifts are implemented on + ! Beam%Type( 4 : 4 ) selects whether beam shifts are implemented on ! boundary reflection ! 'S' yes ! 'N' no @@ -227,12 +227,12 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) Beam%Type( 1:1 ) = Beam%RunType( 2:2 ) SELECT CASE ( Beam%Type( 1:1 ) ) - CASE ( 'G', 'g' , '^', 'B', 'b', 'S' ) + CASE ( 'G', 'g' , '^', 'B', 'b', 'S' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT ! Only do I/O if in the main thread _BEGIN_MASTER(myThid) - WRITE(msgBuf,'(2A)') 'INITENVIHOP initEnv: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP initEnv: ', & 'Unknown beam type (second letter of Beam%Type)' CALL PRINT_ERROR( msgBuf,myThid ) ! Only do I/O in the main thread @@ -240,7 +240,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R initEnv' END SELECT - + END IF ! Beam%RunType( 1:1 ) /= 'R' ... @@ -259,7 +259,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! CALL initBTY( Bdry%Bot%HS%Opt( 2:2 ), Bdry%Bot%HS%Depth, myThid ) ! ! (top and bottom): OPTIONAL ! CALL readReflectionCoefficient( Bdry%Bot%HS%Opt( 1:1 ), & -! Bdry%Top%HS%Opt( 2:2 ), myThid ) +! Bdry%Top%HS%Opt( 2:2 ), myThid ) ! ! Source Beam Pattern: OPTIONAL, default is omni source pattern ! SBPFlag = Beam%RunType( 3:3 ) ! CALL readPat( myThid ) @@ -273,16 +273,16 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! STOP 'ABNORMAL END: S/R IHOP_INIT' ! ENDIF ! Pos%theta( 1 ) = 0. -! ! -!! Allocate arrival and U variables on all MPI processes +! +!! Allocate arrival and U variables on all MPI processes ! SELECT CASE ( Beam%RunType( 5:5 ) ) ! CASE ( 'I' ) ! NRz_per_range = 1 ! irregular grid ! CASE DEFAULT ! NRz_per_range = Pos%NRz ! rectilinear grid ! END SELECT -! +! ! IF ( ALLOCATED( U ) ) DEALLOCATE( U ) ! SELECT CASE ( Beam%RunType( 1:1 ) ) ! ! for a TL calculation, allocate space for the pressure matrix @@ -290,7 +290,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! ALLOCATE ( U( NRz_per_range, Pos%NRr ), Stat = iAllocStat ) ! IF ( iAllocStat/=0 ) THEN !#ifdef IHOP_WRITE_OUT -! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & +! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & ! 'Insufficient memory for TL matrix: reduce Nr*NRz' ! CALL PRINT_ERROR( msgBuf,myThid ) !#endif /* IHOP_WRITE_OUT */ @@ -304,18 +304,18 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! ALLOCATE ( U( 1,1 ), Stat = iAllocStat ) ! open a dummy variable ! U( 1,1 ) = 0. ! init default value ! END SELECT -! +! ! ! for an arrivals run, allocate space for arrivals matrices ! SELECT CASE ( Beam%RunType( 1:1 ) ) ! CASE ( 'A', 'a', 'e' ) ! ! allow space for at least MinNArr arrivals -! MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & +! MaxNArr = MAX( ArrivalsStorage / ( NRz_per_range * Pos%NRr ), & ! MinNArr ) ! ALLOCATE ( Arr( MaxNArr, Pos%NRr, NRz_per_range ), & ! NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) ! IF ( iAllocStat /= 0 ) THEN !#ifdef IHOP_WRITE_OUT -! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & +! WRITE(msgBuf,'(2A)') 'BELLHOP IHOP_INIT: ', & ! 'Not enough allocation for Arr; reduce ArrivalsStorage' ! CALL PRINT_ERROR( msgBuf,myThid ) !#endif /* IHOP_WRITE_OUT */ @@ -326,13 +326,13 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! ALLOCATE ( Arr( 1, NRz_per_range, Pos%NRr ), & ! NArr( Pos%NRr, NRz_per_range ), Stat = iAllocStat ) ! END SELECT -! +! ! ! init Arr, Narr ! ! Arr = something ! NArr( 1:Pos%NRr, 1:NRz_per_range ) = 0 ! IEsco22 unnecessary? NArr = 0 below -! +! !#ifdef IHOP_WRITE_OUT -! WRITE(msgBuf,'(A)') +! WRITE(msgBuf,'(A)') ! ! In adjoint mode we do not write output besides on the first run ! IF (IHOP_dumpfreq.GE.0) & ! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) @@ -343,7 +343,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) !! open all output files ! IF ( IHOP_dumpfreq .GE. 0 ) & ! CALL OpenOutputFiles( IHOP_fileroot, myTime, myIter, myThid ) -! +! ! ! Run Bellhop solver on a single processor ! if (numberOfProcs.gt.1) then !! Use same single processID as IHOP COST package @@ -352,7 +352,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! CALL CPU_TIME( Tstart ) ! CALL BellhopCore(myThid) ! CALL CPU_TIME( Tstop ) -!! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. +!! Alternitavely, we can broadcast relevant info to all mpi processes Ask P. !!#ifdef ALLOW_COST !! ! Broadcast info to all MPI procs for COST function accumulation !! CALL MPI_BCAST(i, 1, MPI_COMPLEX, myProcId, MPI_COMM_MODEL, ierr) @@ -364,7 +364,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! CALL BellhopCore(myThid) ! CALL CPU_TIME( Tstop ) ! endif -! +! !#ifdef IHOP_WRITE_OUT ! IF ( IHOP_dumpfreq.GE.0 ) THEN ! ! print run time @@ -379,7 +379,7 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) ! WRITE(msgBuf, '(A,G15.3,A)' ) 'CPU Time = ', Tstop-Tstart, 's' ! CALL PRINT_MESSAGE(msgBuf, PRTFile, SQUEEZE_RIGHT, myThid) -! +! ! ! close all files ! IF ( IHOP_dumpfreq .GE. 0) THEN ! SELECT CASE ( Beam%RunType( 1:1 ) ) @@ -390,11 +390,11 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! CASE ( 'R', 'E' ) ! ray and eigen ray trace ! CLOSE( RAYFile ) ! CASE ( 'e' ) -! CLOSE( RAYFile ) +! CLOSE( RAYFile ) ! CLOSE( ARRFile ) ! IF ( writeDelay ) CLOSE( DELFile ) ! END SELECT -! +! ! if (numberOfProcs.gt.1) then ! ! Erase prtfiles that aren't on procid = 0 ! if(myProcId.ne.0) then @@ -408,10 +408,10 @@ SUBROUTINE INIT_FIXED_ENV ( myThid ) ! ENDIF ! ENDIF !#endif /* IHOP_WRITE_OUT */ - + RETURN - END !SUBROUTINE - + END !SUBROUTINE + ! **********************************************************************! SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) USE atten_mod, only: T, Salinity, pH, z_bar, iBio, NBioLayers, bio @@ -431,7 +431,7 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN= 1), INTENT( OUT ) :: BC ! Boundary condition type CHARACTER (LEN= 2), INTENT( INOUT ) :: AttenUnit @@ -449,7 +449,7 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) CASE ( 'N','C','P','S','Q','A' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & 'Unknown option for SSP approximation' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -461,7 +461,7 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) CASE ( 'N','F','M','W','Q','L' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & 'Unknown attenuation units' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -473,7 +473,7 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) CASE ( 'T','F','B',' ' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & 'Unknown top option letter in fourth position' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -485,7 +485,7 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) CASE ( '-', '_', ' ' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & 'Unknown top option letter in fifth position' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -497,7 +497,7 @@ SUBROUTINE ReadTopOpt( BC, AttenUnit, myThid ) CASE ( ' ' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadTopOpt: ', & 'Unknown top option letter in sixth position' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -513,7 +513,7 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) USE atten_mod, only: CRCI USE bdry_mod, only: HSInfo USE ssp_mod, only: alphaR, betaR, alphaI, betaI, rhoR - + ! =========================================================================== ! == Global Variables == #include "SIZE.h" @@ -528,7 +528,7 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN=2), INTENT( IN ) :: AttenUnit TYPE ( HSInfo ), INTENT( INOUT ) :: HS @@ -544,12 +544,12 @@ SUBROUTINE TopBot( AttenUnit, HS, myThid ) bPower = 1.0 fT = 1D20 rhoR = 1.0 - + SELECT CASE ( HS%BC ) CASE ( 'V','R','A','G','F','W','P' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP TopBot: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP TopBot: ', & 'Unknown boundary condition type' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -585,7 +585,7 @@ SUBROUTINE AllocatePos( Nx, x_out, x_in ) ! Allocate and populate Pos structure from data.ihop - INTEGER, INTENT( IN ) :: Nx + INTEGER, INTENT( IN ) :: Nx REAL(KIND=_RL90), INTENT( IN ) :: x_in(:) REAL(KIND=_RL90), ALLOCATABLE, INTENT( OUT ) :: x_out(:) INTEGER :: i @@ -609,7 +609,7 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) ! Read the RunType variable and print to .prt file USE srPos_mod, only: Pos - + ! =========================================================================== ! == Global Variables == #include "EEPARAMS.h" @@ -619,7 +619,7 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER (LEN= 7), INTENT( INOUT ) :: RunType CHARACTER (LEN=10), INTENT( INOUT ) :: PlotType @@ -628,7 +628,7 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) CASE ( 'R','E','I','S','C','A','a','e' ) CASE DEFAULT #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & 'Unknown RunType selected' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ @@ -653,7 +653,7 @@ SUBROUTINE ReadRunType( RunType, PlotType, myThid ) CASE ( 'I' ) IF ( Pos%NRz /= Pos%NRr ) THEN #ifdef IHOP_WRITE_OUT - WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & + WRITE(msgBuf,'(2A)') 'INITENVIHOP ReadRunType: ', & 'Irregular grid option selected with NRz not equal to Nr' CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ diff --git a/src/ihop_mod.F90 b/src/ihop_mod.F90 index dfa1eb3..e9df5e1 100644 --- a/src/ihop_mod.F90 +++ b/src/ihop_mod.F90 @@ -26,7 +26,7 @@ MODULE ihop_mod public rad2deg, i, & PRTFile, RAYFile, DELFile, SHDFile, ARRFile, SSPFile,& - ATIFile, BTYFile, BRCFile, TRCFile, IRCFile, SBPFile,& + ATIFile, BTYFile, BRCFile, TRCFile, IRCFile, SBPFile,& MaxN, Nrz_per_range, iStep, afreq, SrcDeclAngle, & Title, Beam, ray2D, ray2DPt, iSmallStepCtr, rxyz diff --git a/src/ihop_readparms.F b/src/ihop_readparms.F index 488dc22..5e96ef6 100644 --- a/src/ihop_readparms.F +++ b/src/ihop_readparms.F @@ -1,7 +1,7 @@ #include "IHOP_OPTIONS.h" C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| -CBOP +CBOP C !ROUTINE: IHOP_READPARMS C !INTERFACE: @@ -34,7 +34,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) C iUnit :: Work variable for IO unit number CHARACTER*(MAX_LEN_MBUF) msgBuf INTEGER iUnit, IL, num_file - INTEGER i, j + INTEGER i, j LOGICAL exst CHARACTER*(128) fname @@ -78,7 +78,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) & IHOP_step NAMELIST /IHOP_PARM03/ - & writeDelay, + & writeDelay, & useSSPFile, & IHOP_interpfile, & ihop_iter, @@ -138,13 +138,13 @@ SUBROUTINE IHOP_READPARMS( myThid ) C Check paramters of IHOP_PARM01 IF ( IHOP_fileroot.EQ.'' ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "IHOP_fileroot" ', - & 'Provide fileroot for ihop package' + & 'Provide fileroot for ihop package' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF IF ( IHOP_title.EQ.'ihop' ) THEN WRITE(msgBuf, '(2A)') '**WARNING** IHOP_READPARMS: "IHOP_title"', - & ' using default title name' + & ' using default title name' CALL PRINT_MESSAGE( msgBuf, errorMessageUnit, & SQUEEZE_RIGHT, myThid ) ENDIF @@ -194,7 +194,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) & IHOP_topopt(1:1) .NE. 'A' ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "IHOP_topopt(1:1)" ', - & 'unknown option for SSP approximation' + & 'unknown option for SSP approximation' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF @@ -208,7 +208,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) & IHOP_topopt(2:2) .NE. 'P' ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "IHOP_topopt(2:2)" ', - & 'unknown top boundary condition type' + & 'unknown top boundary condition type' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF @@ -235,7 +235,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) & IHOP_botopt(1:1) .NE. 'P' ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "IHOP_botopt(1:1)" ', - & 'unknown bottom boundary condition type' + & 'unknown bottom boundary condition type' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF @@ -245,7 +245,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) & IHOP_botopt(2:2) .NE. '~' ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "IHOP_botopt(2:2)" ', - & 'either select or deselect bathymetry file' + & 'either select or deselect bathymetry file' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF @@ -281,14 +281,14 @@ SUBROUTINE IHOP_READPARMS( myThid ) C Check paramters of IHOP_PARM03 IF ( IHOP_interpfile.EQ.'' ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "IHOP_interpfile" ', - & 'Provide interpolation file name for ihop package' + & 'Provide interpolation file name for ihop package' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF #ifdef ALLOW_COST C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| -C-- Default values for IHOP_COST_NML +C-- Default values for IHOP_COST_NML ihopdoncoutput = .true. ihopObsDir = ' ' DO num_file=1,NFILESMAX_IHOP @@ -312,7 +312,7 @@ SUBROUTINE IHOP_READPARMS( myThid ) INQUIRE( FILE=fname, EXIST=exst ) IF ( .NOT.exst ) THEN WRITE(msgBuf, '(2A)') 'S/R IHOP_READPARMS: "ihopObsFiles " ', - & 'Provide observations file name for ihop package' + & 'Provide observations file name for ihop package' CALL PRINT_ERROR( msgBuf, myThid ) STOP 'ABNORMAL END: S/R IHOP_READPARMS' ENDIF diff --git a/src/ihop_sound_speed.F b/src/ihop_sound_speed.F index 8816a38..0bba4bf 100644 --- a/src/ihop_sound_speed.F +++ b/src/ihop_sound_speed.F @@ -17,7 +17,7 @@ SUBROUTINE IHOP_SOUND_SPEED( C | the model setup specific EOS. C | C | o Reference: -C | C. Chen and F. J. Millero, "Speed of sound in seawater at +C | C. Chen and F. J. Millero, "Speed of sound in seawater at C | high pressures," C | J. Acoust. Soc. Am. 672.5, 1129-1135 (1977). C *==========================================================* @@ -40,7 +40,7 @@ SUBROUTINE IHOP_SOUND_SPEED( C myThid :: Thread number for this instance of the routine. INTEGER myThid -#ifdef ALLOW_IHOP +#ifdef ALLOW_IHOP C !FUNCTIONS: C _RL CHEN_MILLERO C EXTERNAL CHEN_MILLERO @@ -103,7 +103,7 @@ SUBROUTINE IHOP_SOUND_SPEED( C- end-if calc_soundSpeed ENDIF -#endif /* ALLOW_IHOP */ +#endif /* ALLOW_IHOP */ RETURN END diff --git a/src/influence.F90 b/src/influence.F90 index cf24127..6834c84 100644 --- a/src/influence.F90 +++ b/src/influence.F90 @@ -6,7 +6,7 @@ MODULE influence ! Ivana Escobar ! - ! Compute the beam influence, i.e. the contribution of a single beam to the + ! Compute the beam influence, i.e. the contribution of a single beam to the ! complex pressure ! mbp 12/2018, based on much older subroutines @@ -46,7 +46,7 @@ MODULE influence SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) use arr_mod, only: NArr, Arr !RG - ! Geometrically-spreading beams with a hat-shaped beam in ray-centered + ! Geometrically-spreading beams with a hat-shaped beam in ray-centered ! coordinates ! == Routine Arguments == @@ -54,7 +54,7 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: alpha, dalpha ! take-off angle radians COMPLEX, INTENT( INOUT ) :: U( NRz_per_range, Pos%NRr ) ! complex pressure field @@ -87,12 +87,12 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) RcvrDeclAngleV( 1:Beam%Nsteps ) = rad2deg * & ATAN2( ray2D( 1:Beam%Nsteps )%t( 2 ), ray2D( 1:Beam%Nsteps )%t( 1 ) ) - ! During reflection imag(q) is constant and adjacent normals cannot bracket + ! During reflection imag(q) is constant and adjacent normals cannot bracket ! a segment of the TL line, so no special treatment is necessary - + ! point source (cylindrical coordinates): default behavior Ratio1 = 1.0d0 !RG - IF ( Beam%RunType( 4:4 ) == 'R' ) Ratio1 = SQRT( ABS( COS( alpha ) ) ) + IF ( Beam%RunType( 4:4 ) == 'R' ) Ratio1 = SQRT( ABS( COS( alpha ) ) ) ray2D( 1:Beam%Nsteps )%Amp = Ratio1 * SQRT( ray2D( 1:Beam%Nsteps )%c ) & * ray2D( 1:Beam%Nsteps )%Amp ! pre-apply some scaling @@ -102,9 +102,9 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) phase = 0.0 qOld = ray2D( 1 )%q( 1 ) ! used to track KMAH index - + ! If normal is parallel to horizontal receiver line - IF ( ABS( znV( 1 ) ) < 1D-6 ) THEN + IF ( ABS( znV( 1 ) ) < 1D-6 ) THEN nA = 1D10 rA = 1D10 irA = 1 @@ -120,9 +120,9 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) Stepping: DO iS = 2, Beam%Nsteps !$TAF store ira,irb,na,nb,phase,qold,ra = iRayCen1 skip_step = .FALSE. - + ! Compute ray-centered coordinates, (znV, rnV) - + ! If normal is parallel to TL-line, skip to the next step on ray IF (ABS(znV(iS)) < 1D-10) THEN skip_step = .TRUE. @@ -130,12 +130,12 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) ELSE nB = (zR - ray2D(iS)%x(2)) / znV(iS) rB = ray2D(iS)%x(1) + nB * rnV(iS) - + ! Find index of receiver: assumes uniform spacing in Pos%Rr irB = MAX(MIN(INT((rB - Pos%Rr(1)) / Pos%Delta_r) + 1, & Pos%NRr), & 1) - + ! Detect and skip duplicate points (happens at boundary reflection) IF (ABS(ray2D(iS)%x(1) - ray2D(iS - 1)%x(1)) < & 1.0D3 * SPACING(ray2D(iS)%x(1)) & @@ -146,7 +146,7 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) skip_step = .TRUE. END IF END IF - + IF (.NOT. skip_step) THEN !!! this should be pre-computed q = ray2D(iS - 1)%q(1) @@ -155,13 +155,13 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) (q >= 0.0D0 .AND. qOld < 0.0D0)) & phase = phase + PI / 2.0D0 qOld = q - + RcvrDeclAngle = RcvrDeclAngleV(iS) - + ! *** Compute contributions to bracketted receivers *** II = 0 IF (irB <= irA) II = 1 ! going backwards in range - + ! Compute influence for each receiver DO ir = irA + 1 - II, irB + II, SIGN(1, irB - irA) !$TAF store Arr(:,ir,iz),NArr(ir,iz) = iRayCen2 @@ -169,7 +169,7 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) n = ABS(nA + W * (nB - nA)) q = ray2D(iS - 1)%q(1) + W * dq(iS - 1) ! interpolated amplitude L = ABS(q) / q0 ! beam radius - + IF (n < L) THEN ! in beam window: update delay, Amp, phase !$TAF store w = iRayCen2 delay = ray2D(iS - 1)%tau + W * dtau(iS - 1) @@ -181,12 +181,12 @@ SUBROUTINE InfluenceGeoHatRayCen( U, alpha, dalpha, myThid ) IF ((q <= 0.0D0 .AND. qOld > 0.0D0) .OR. & (q >= 0.0D0 .AND. qOld < 0.0D0)) & phaseInt = phase + PI / 2.0D0 ! phase shifts at caustics - + CALL ApplyContribution(U(iz, ir)) END IF END DO END IF - + rA = rB nA = nB irA = irB @@ -207,7 +207,7 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: alpha, & ! take-off angle, radians Dalpha ! angular spacing @@ -230,14 +230,14 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) rA = ray2D( 1 )%x( 1 ) ! range at start of ray, typically 0 ! find index of first receiver to the right of rA - irT = MINLOC( Pos%Rr( 1 : Pos%NRr ), MASK = Pos%Rr( 1 : Pos%NRr ) > rA ) + irT = MINLOC( Pos%Rr( 1 : Pos%NRr ), MASK = Pos%Rr( 1 : Pos%NRr ) > rA ) ir = irT( 1 ) ! if ray is left-traveling, get the first receiver to the left of rA - IF ( ray2D( 1 )%t( 1 ) < 0.0d0 .AND. ir > 1 ) ir = ir - 1 + IF ( ray2D( 1 )%t( 1 ) < 0.0d0 .AND. ir > 1 ) ir = ir - 1 ! point source: the default option Ratio1 = 1.0d0 !RG - IF ( Beam%RunType( 4 : 4 ) == 'R' ) Ratio1 = SQRT( ABS( COS( alpha ) ) ) + IF ( Beam%RunType( 4 : 4 ) == 'R' ) Ratio1 = SQRT( ABS( COS( alpha ) ) ) Stepping: DO iS = 2, Beam%Nsteps @@ -247,10 +247,10 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) x_ray = ray2D( iS-1 )%x ! compute normalized tangent (we need to measure the step length) - rayt = ray2D( iS )%x - x_ray + rayt = ray2D( iS )%x - x_ray rlen = NORM2( rayt ) ! if duplicate point in ray, skip to next step along the ray - IF ( rlen .GE. 1.0D3 * SPACING( ray2D( iS )%x( 1 ) ) ) THEN + IF ( rlen .GE. 1.0D3 * SPACING( ray2D( iS )%x( 1 ) ) ) THEN !$TAF store rlen,rayt= iiitape1 @@ -266,10 +266,10 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) IF( q <= 0.0 .AND. qOld > 0.0 .OR. q >= 0.0 .AND. qOld < 0.0 )& phase = phase + PI / 2. ! phase shifts at caustics qOld = q - + ! Radius calc from beam radius projected onto vertical line RadiusMax = MAX( ABS( q ), ABS( ray2D( iS )%q( 1 ) ) ) & - / q0 / ABS( rayt( 1 ) ) ! IESCO24: AKA rayn( 2 ) + / q0 / ABS( rayt( 1 ) ) ! IESCO24: AKA rayn( 2 ) ! depth limits of beam; IESCO22: a large range of about 1/2 box depth IF ( ABS( rayt( 1 ) ) > 0.5 ) THEN ! shallow angle ray @@ -293,7 +293,7 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) IF ( Beam%RunType( 5 : 5 ) == 'I' ) THEN ! irregular grid x_rcvr( 2, 1 ) = Pos%Rz( ir ) ELSE ! default: rectilinear grid - x_rcvr( 2, 1:NRz_per_range ) = Pos%Rz( 1:NRz_per_range ) + x_rcvr( 2, 1:NRz_per_range ) = Pos%Rz( 1:NRz_per_range ) END IF RcvrDepths: DO iz = 1, NRz_per_range @@ -302,13 +302,13 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) IF ( x_rcvr( 2, iz ) .GE. zmin & .AND. x_rcvr( 2, iz ) .LE. zmax ) THEN ! normalized proportional distance along ray - s = DOT_PRODUCT( x_rcvr( :, iz ) - x_ray, rayt ) / rlen + s = DOT_PRODUCT( x_rcvr( :, iz ) - x_ray, rayt ) / rlen ! normal distance to ray - n = ABS( DOT_PRODUCT( x_rcvr( :, iz ) - x_ray, rayn ) ) + n = ABS( DOT_PRODUCT( x_rcvr( :, iz ) - x_ray, rayn ) ) ! interpolated amplitude in [meters] - q = q + s*dqds + q = q + s*dqds ! beam radius; IESCO22 smaller then previous RadiusMax - RadiusMax = ABS( q / q0 ) + RadiusMax = ABS( q / q0 ) IF ( n < RadiusMax ) THEN #ifdef IHOP_WRITE_OUT @@ -319,13 +319,13 @@ SUBROUTINE InfluenceGeoHatCart( U, alpha, Dalpha, myThid ) SQUEEZE_RIGHT, myThid ) #endif /* IHOP_WRITE_OUT */ ! interpolated delay - delay = ray2D( iS-1 )%tau + s*dtauds + delay = ray2D( iS-1 )%tau + s*dtauds Amp = Ratio1 * SQRT( ray2D( iS )%c / ABS( q ) ) & * ray2D( iS )%Amp ! hat function: 1 on center, 0 on edge - W = ( RadiusMax - n ) / RadiusMax + W = ( RadiusMax - n ) / RadiusMax Amp = Amp*W - + IF ( q <= 0.0d0 .AND. qOld > 0.0d0 & .OR. q >= 0.0d0 .AND. qOld < 0.0d0 ) THEN phaseInt = phase + PI / 2. ! phase shifts at caustics @@ -365,14 +365,14 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) use arr_mod, only: NArr, Arr !RG ! Geometric, Gaussian beams in Cartesian coordintes - + ! beam window: kills beams outside e**(-0.5 * ibwin**2 ) ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER, PARAMETER :: BeamWindow = 2 REAL (KIND=_RL90), INTENT( IN ) :: alpha, dalpha ! take-off angle, angular spacing @@ -397,11 +397,11 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) ! what if there is a single receiver (ir = 0 possible) ! irT: find index of first receiver to the right of rA - irT = MINLOC( Pos%Rr( 1 : Pos%NRr ), MASK = Pos%Rr( 1 : Pos%NRr ) > rA ) + irT = MINLOC( Pos%Rr( 1 : Pos%NRr ), MASK = Pos%Rr( 1 : Pos%NRr ) > rA ) ir = irT( 1 ) ! if ray is left-traveling, get the first receiver to the left of rA - IF ( ray2D( 1 )%t( 1 ) < 0.0d0 .AND. ir > 1 ) ir = ir - 1 + IF ( ray2D( 1 )%t( 1 ) < 0.0d0 .AND. ir > 1 ) ir = ir - 1 ! sqrt( 2 * PI ) represents a sum of Gaussians in free space IF ( Beam%RunType( 4 : 4 ) == 'R' ) THEN @@ -415,7 +415,7 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) rB = ray2D( iS )%x( 1 ) x_ray = ray2D( iS - 1 )%x - ! compute normalized tangent (compute it because we need to measure the + ! compute normalized tangent (compute it because we need to measure the ! step length) rayt = ray2D( iS )%x - ray2D( iS - 1 )%x rlen = NORM2( rayt ) @@ -440,11 +440,11 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) ! calculate beam width beam radius projected onto vertical line lambda = ray2D( iS-1 )%c / IHOP_freq sigma = MAX( ABS( q ), ABS( ray2D( iS )%q( 1 ) ) ) & - / q0 / ABS( rayt( 1 ) ) ! IESCO24: AKA rayn( 2 ) + / q0 / ABS( rayt( 1 ) ) ! IESCO24: AKA rayn( 2 ) sigma = MAX( sigma, & MIN( 0.2*IHOP_freq*REAL( ray2D( iS )%tau ), & PI*lambda ) ) - ! Note on min: "Weinberg and Keenan suggest limiting a beam to a + ! Note on min: "Weinberg and Keenan suggest limiting a beam to a ! point, by imposing a minimum beam width of pilambda." ! - Jensen, Comp OA 2011 ! default is 2 standard deviations of coverage of the Gaussian curve @@ -480,13 +480,13 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) .AND. x_rcvr( 2 ) .LE. zmax ) THEN ! proportional distance along ray - s = DOT_PRODUCT( x_rcvr - x_ray, rayt ) / rlen + s = DOT_PRODUCT( x_rcvr - x_ray, rayt ) / rlen ! normal distance to ray - n = ABS( DOT_PRODUCT( x_rcvr - x_ray, rayn ) ) + n = ABS( DOT_PRODUCT( x_rcvr - x_ray, rayn ) ) ! interpolated amplitude in [meters] - q = q + s*dqds + q = q + s*dqds ! beam radius; IESCO22 smaller then previous RadiusMax - sigma = ABS( q / q0 ) + sigma = ABS( q / q0 ) sigma = MAX( sigma, & MIN( 0.2*IHOP_freq*REAL( ray2D( iS )%tau ), & PI*lambda ) ) @@ -501,11 +501,11 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) #endif /* IHOP_WRITE_OUT */ ! interpolated delay A = ABS( q0 / q ) - delay = ray2D( iS-1 )%tau + s*dtauds + delay = ray2D( iS-1 )%tau + s*dtauds Amp = Ratio1 * SQRT( ray2D( iS )%c / ABS( q ) ) & * ray2D( iS )%Amp ! W : Gaussian decay - W = EXP( -0.5*( n / sigma )**2 ) / ( sigma*A ) + W = EXP( -0.5*( n / sigma )**2 ) / ( sigma*A ) Amp = Amp*W phaseInt = ray2D( iS )%Phase + phase IF ( q <= 0.0d0 .AND. qOld > 0.0d0 & @@ -539,7 +539,7 @@ SUBROUTINE InfluenceGeoGaussianCart( U, alpha, Dalpha, myThid ) END !SUBROUTINE InfluenceGeoGaussianCart ! **********************************************************************! - + SUBROUTINE ApplyContribution( U ) USE ihop_mod, only: afreq @@ -581,7 +581,7 @@ SUBROUTINE ApplyContribution( U ) RETURN END !SUBROUTINE ApplyContribution - + ! **********************************************************************! SUBROUTINE ScalePressure( Dalpha, c, r, U, NRz, Nr, RunType, freq ) @@ -606,7 +606,7 @@ SUBROUTINE ScalePressure( Dalpha, c, r, U, NRz, Nr, RunType, freq ) END SELECT ! If incoherent run, convert intensity to pressure - IF ( RunType( 1 : 1 ) /= 'C' ) U = SQRT( REAL( U ) ) + IF ( RunType( 1 : 1 ) /= 'C' ) U = SQRT( REAL( U ) ) ! scale and/or incorporate cylindrical spreading Ranges: DO ir = 1, Nr diff --git a/src/monotonic_mod.F90 b/src/monotonic_mod.F90 index 9b4043a..2e7969d 100644 --- a/src/monotonic_mod.F90 +++ b/src/monotonic_mod.F90 @@ -12,14 +12,14 @@ MODULE monotonic_mod IMPLICIT NONE PRIVATE - + ! public interfaces !======================================================================= public monotonic !======================================================================= - + INTERFACE monotonic MODULE PROCEDURE monotonic_sngl, monotonic_dble END INTERFACE monotonic @@ -32,7 +32,7 @@ FUNCTION monotonic_sngl( x, N ) monotonic_sngl = .TRUE. IF ( N == 1 ) RETURN - IF ( ANY( x( 2 : N ) <= x( 1 : N - 1 ) ) ) monotonic_sngl = .FALSE. + IF ( ANY( x( 2 : N ) <= x( 1 : N - 1 ) ) ) monotonic_sngl = .FALSE. RETURN END !FUNCTION monotonic_sngl @@ -43,8 +43,8 @@ FUNCTION monotonic_dble( x, N ) monotonic_dble = .TRUE. IF ( N == 1 ) RETURN - IF ( ANY( x( 2 : N ) <= x( 1 : N - 1 ) ) ) monotonic_dble = .FALSE. + IF ( ANY( x( 2 : N ) <= x( 1 : N - 1 ) ) ) monotonic_dble = .FALSE. RETURN END !FUNCTION monotonic_dble - + END !MODULE monotonic_mod diff --git a/src/pchip_mod.F90 b/src/pchip_mod.F90 index af77ad3..31b8d9c 100644 --- a/src/pchip_mod.F90 +++ b/src/pchip_mod.F90 @@ -35,7 +35,7 @@ SUBROUTINE PCHIP( x, y, N, PolyCoef, csWork ) ! Computing, 5(2):300-304, (1984) https://doi.org/10.1137/0905021 ! ! F. N. Fritsch and R. E. Carlson. "Monotone Piecewise Cubic Interpolation", - ! SIAM Journal on Numerical Analysis, 17(2):238-246, (1980) + ! SIAM Journal on Numerical Analysis, 17(2):238-246, (1980) ! https://doi.org/10.1137/0717021 ! ! N is the number of nodes @@ -275,7 +275,7 @@ FUNCTION fprime_right_end( del1, del2, fprime ) ! adjust derivative value to enforce monotonicity fprime_right_end = 3.0D0 * del2; END IF - + RETURN END !FUNCTION fprime_right_end diff --git a/src/refcoef.F90 b/src/refcoef.F90 index d1ed41a..dde4bb3 100644 --- a/src/refcoef.F90 +++ b/src/refcoef.F90 @@ -41,7 +41,7 @@ MODULE refCoef TYPE(ReflectionCoef), ALLOCATABLE :: RBot( : ), RTop( : ) CONTAINS -! NOTE: To be able to read using direct access, we assume a fixed pad of +! NOTE: To be able to read using direct access, we assume a fixed pad of ! characters per line. So each line in BRCFile/TRCFile will have a fixed length ! of 100 characters. Helps TAF create the adjoint model. IESCO24 SUBROUTINE ReadReflectionCoefficient( BotRC, TopRC, myThid ) @@ -53,7 +53,7 @@ SUBROUTINE ReadReflectionCoefficient( BotRC, TopRC, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == ! flag set to 'F' if refl. coef. is to be read from a File CHARACTER (LEN=1), INTENT( IN ) :: BotRC, TopRC @@ -104,7 +104,7 @@ SUBROUTINE ReadReflectionCoefficient( BotRC, TopRC, myThid ) DO itheta=1,NBotPts rec = itheta+1 - READ( BRCFile,REC=rec,IOSTAT=IOStat,FMT='(A)' ) line + READ( BRCFile,REC=rec,IOSTAT=IOStat,FMT='(A)' ) line READ( line,'(3F5.3)' ) RBot(itheta)%theta, RBot(itheta)%R, & RBot(itheta)%phi ENDDO @@ -146,7 +146,7 @@ SUBROUTINE ReadReflectionCoefficient( BotRC, TopRC, myThid ) #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) & - WRITE( PRTFile,'(2A,I10)' ) 'Number of points in top reflection ', & + WRITE( PRTFile,'(2A,I10)' ) 'Number of points in top reflection ', & 'coefficient = ', NTopPts #endif /* IHOP_WRITE_OUT */ @@ -163,7 +163,7 @@ SUBROUTINE ReadReflectionCoefficient( BotRC, TopRC, myThid ) DO itheta=1,NTopPts rec = itheta+1 - READ( TRCFile,REC=rec,IOSTAT=IOStat,FMT='(A)' ) line + READ( TRCFile,REC=rec,IOSTAT=IOStat,FMT='(A)' ) line READ( line,'(3F5.3)' ) RTop(itheta)%theta, RTop(itheta)%R, & RTop(itheta)%phi ENDDO @@ -246,7 +246,7 @@ SUBROUTINE InterpolateReflectionCoefficient( RInt, R, NPts ) iLeft = 1 iRight = NPts ! thetaIntr should be unnecessary? probably used when I was doing complex angles - thetaIntr = REAL( RInt%Theta ) + thetaIntr = REAL( RInt%Theta ) ! Three cases: ThetaInt left, in, or right of tabulated interval @@ -270,7 +270,7 @@ SUBROUTINE InterpolateReflectionCoefficient( RInt, R, NPts ) RInt%phi = 0.0 ! R( iRight )%phi ELSE - ! Search for bracketting abscissas: Log2( NPts ) stabs required for a + ! Search for bracketting abscissas: Log2( NPts ) stabs required for a ! bracket DO iLR = 1, NPts @@ -300,7 +300,7 @@ SUBROUTINE InterpolateIRC( x, f, g, iPower, xTab, fTab, gTab, iTab, NkTab ) ! Internal reflection coefficient interpolator. ! Returns f, g, iPower for given x using tabulated values. - ! Uses polynomial interpolation to approximate the function between the + ! Uses polynomial interpolation to approximate the function between the ! tabulated values USE poly_mod, only: Poly diff --git a/src/sort_mod.F90 b/src/sort_mod.F90 index b1bb58b..54f33fb 100644 --- a/src/sort_mod.F90 +++ b/src/sort_mod.F90 @@ -127,7 +127,7 @@ SUBROUTINE Sort_cmplx( x, N ) x( 2 : I ) = x( 1 : I - 1 ) x( 1 ) = xTemp ! goes in the first position !else Binary search for its place - ELSE IF ( REAL( xTemp ) > REAL( x( I - 1 ) ) ) THEN + ELSE IF ( REAL( xTemp ) > REAL( x( I - 1 ) ) ) THEN IRight = I - 1 ILeft = 1 diff --git a/src/splinec_mod.F90 b/src/splinec_mod.F90 index a3dfb03..99d5154 100644 --- a/src/splinec_mod.F90 +++ b/src/splinec_mod.F90 @@ -23,7 +23,7 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) ! SPRINGER-VERLAG. THE INPUT PARAMETER "NDIM" HAS BEEN ADDED TO ! ALLOW FOR MULTIPLE CALLS WITH DIFFERENT VALUES OF N. - DENNIS DUNDORE - ! SUBSTANTIAL MODIFICATIONS MADE BY STEVE WALES, APRIL 1983, + ! SUBSTANTIAL MODIFICATIONS MADE BY STEVE WALES, APRIL 1983, ! PRINCIPALLY TO HANDLE COMPLEX NUMBERS (C) & UPDATE THE FORTRAN. ! ***************************** I N P U T **************************** @@ -51,7 +51,7 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) ! ************************** O U T P U T **************************** - ! C(J,I), J=1,...,4; I=1,...,L=N-1 = THE POLY COEFFS OF THE CUBI! + ! C(J,I), J=1,...,4; I=1,...,L=N-1 = THE POLY COEFFS OF THE CUBI! ! SPLINE WITH INTERIOR KNOTS TAU(2),...,TAU(N-1). PRECISELY, IN THE ! INTERVAL (TAU(I), TAU(I+1)), THE SPLINE F IS GIVEN BY @@ -60,7 +60,7 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) ! WHERE H = X - TAU(I). ! THE COEFFICIENTS CALCULATED ARE, 1) THE VALUE, 2) THE SLOPE, AND - ! 3) THE CURVATURE AT EACH OF THE KNOTS 1 TO N-1, AND 4) THE RATE OF + ! 3) THE CURVATURE AT EACH OF THE KNOTS 1 TO N-1, AND 4) THE RATE OF ! CHANGE OF THE CURVATURE OVER THE FOLLOWING INTERVAL. IN ADDITION, ! WE HAVE THE VALUE AND THE SLOPE AT THE LAST POINT. THE LAST TWO ! POSTIONS AT THE LAST POINT ARE THEN SET TO THE CURVATURE AT THAT @@ -70,7 +70,7 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) ! ********************************************************************** - IMPLICIT INTEGER (I-M) + IMPLICIT INTEGER (I-M) IMPLICIT REAL (KIND=_RL90) (A-H,O-Z) INTEGER, INTENT(IN) :: N, NDIM, IBCBEG, IBCEND REAL (KIND=_RL90), INTENT(IN) :: TAU(N) @@ -162,14 +162,14 @@ SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM) C(4,I-1) = (DIVDF3/DTAU) * (6.0/DTAU) END DO - ! * ADD THE CURVATURE AT THE LAST POINT IN THE THIRD POSITION OF THE + ! * ADD THE CURVATURE AT THE LAST POINT IN THE THIRD POSITION OF THE ! LAST NODE * C(3,N) = C(3,L) + (TAU(N)-TAU(L)) * C(4,L) - ! * ADD THE MEAN VALUE OF THE ENTIRE INTERVAL IN THE FOURTH POSITION OF - ! THE LAST NODE. MEAN VALUE IS CALCULATED AS THE INTEGRAL OVER THE + ! * ADD THE MEAN VALUE OF THE ENTIRE INTERVAL IN THE FOURTH POSITION OF + ! THE LAST NODE. MEAN VALUE IS CALCULATED AS THE INTEGRAL OVER THE ! INTERVAL DIVIDED BY THE LENGTH OF THE INTERVAL. * C(4,N) = (0.0,0.0) diff --git a/src/srpos_mod.F90 b/src/srpos_mod.F90 index 789b7d6..dd8897d 100644 --- a/src/srpos_mod.F90 +++ b/src/srpos_mod.F90 @@ -28,8 +28,8 @@ MODULE srpos_mod !======================================================================= public Pos, Nfreq, freqVec, & - ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec, & - WriteSxSy, WriteSzRz, WriteRcvrRanges, WriteFreqVec + ReadSxSy, ReadSzRz, ReadRcvrRanges, ReadFreqVec, & + WriteSxSy, WriteSzRz, WriteRcvrRanges, WriteFreqVec #ifdef IHOP_THREED public ReadRcvrBearings, WriteRcvrBearings #endif /* IHOP_THREED */ @@ -57,7 +57,7 @@ MODULE srpos_mod SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) ! Optionally reads a vector of source frequencies for a broadband run - ! If the broadband option is not selected, then the input freq (a scalar) + ! If the broadband option is not selected, then the input freq (a scalar) ! is stored in the frequency vector ! IHOP_freq is source frequency @@ -66,7 +66,7 @@ SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER, INTENT( IN ) :: BroadbandOption*( 1 ) INTEGER :: ifreq @@ -99,7 +99,7 @@ SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) END IF ! set default values - freqVec = 0.0 + freqVec = 0.0 IF ( BroadbandOption == 'B' ) THEN freqVec(3) = -999.9 @@ -107,7 +107,7 @@ SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) CALL SubTab( freqVec, Nfreq ) ELSE - freqVec(1) = IHOP_freq + freqVec(1) = IHOP_freq END IF RETURN @@ -118,13 +118,13 @@ SUBROUTINE ReadfreqVec( BroadbandOption, myThid ) SUBROUTINE ReadSxSy( myThid ) ! Reads source x-y coordinates - + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == #ifdef IHOP_THREED @@ -153,7 +153,7 @@ SUBROUTINE ReadSxSy( myThid ) SUBROUTINE ReadSzRz( zMin, zMax, myThid ) ! Reads source and receiver z-coordinates (depths) - ! zMin and zMax are limits for those depths; sources and receivers are + ! zMin and zMax are limits for those depths; sources and receivers are ! shifted to be within those limits ! == Routine Arguments == @@ -191,7 +191,7 @@ SUBROUTINE ReadSzRz( zMin, zMax, myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R ReadSzRz' END IF - + ! Set default values Pos%ws = 0 Pos%isz = 0 @@ -210,7 +210,7 @@ SUBROUTINE ReadRcvrRanges( myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == ! IESCO22: assuming receiver positions are equally spaced @@ -228,13 +228,13 @@ SUBROUTINE ReadRcvrRanges( myThid ) CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R ReadRcvrRanges' - END IF - + END IF + RETURN END !SUBROUTINE ReadRcvrRanges !********************************************************************! - + #ifdef IHOP_THREED SUBROUTINE ReadRcvrBearings( myThid ) ! for 3D bellhop @@ -243,7 +243,7 @@ SUBROUTINE ReadRcvrBearings( myThid ) ! for 3D bellhop ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == ! IEsco23: NOT SUPPORTED IN ihop @@ -269,8 +269,8 @@ SUBROUTINE ReadRcvrBearings( myThid ) ! for 3D bellhop CALL PRINT_ERROR( msgBuf,myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R ReadRcvrBearings' - END IF - + END IF + RETURN END !SUBROUTINE ReadRcvrBearings #endif /* IHOP_THREED */ @@ -289,14 +289,14 @@ SUBROUTINE ReadVector( Nx, x, Description, Units, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER, INTENT( IN ) :: Nx REAL (KIND=_RL90), ALLOCATABLE, INTENT( INOUT ) :: x( : ) CHARACTER, INTENT( IN ) :: Description*( * ), & Units*( * ) INTEGER :: ix - + IF ( Nx <= 0 ) THEN #ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(2A)') 'SRPOS_MOD ReadVector: ', & @@ -306,7 +306,7 @@ SUBROUTINE ReadVector( Nx, x, Description, Units, myThid ) STOP 'ABNORMAL END: S/R ReadVector' END IF - IF ( .NOT. ALLOCATED( x ) ) THEN + IF ( .NOT. ALLOCATED( x ) ) THEN ALLOCATE( x( MAX( 3, Nx ) ), Stat = IAllocStat ) IF ( IAllocStat /= 0 ) THEN #ifdef IHOP_WRITE_OUT @@ -340,7 +340,7 @@ SUBROUTINE writeFreqVec( BroadbandOption, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == CHARACTER*(1), INTENT( IN ) :: BroadbandOption INTEGER :: ifreq @@ -354,9 +354,9 @@ SUBROUTINE writeFreqVec( BroadbandOption, myThid ) WRITE(msgBuf,'(2A)')'___________________________________________',& '________________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A,I10)') 'Number of frequencies =', Nfreq CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -383,13 +383,13 @@ SUBROUTINE writeFreqVec( BroadbandOption, myThid ) SUBROUTINE WriteSxSy( myThid ) ! Writes source x-y coordinates - + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == #ifdef IHOP_THREED @@ -474,17 +474,17 @@ SUBROUTINE WriteRcvrRanges( myThid ) REAL(KIND=_RL90) :: x(SIZE(Pos%Rr)) x = Pos%Rr / 1000.0 - + #ifdef IHOP_WRITE_OUT ! IESCO22: assuming receiver positions are equally spaced CALL WriteVector( Pos%NRr, x, 'Receiver ranges, Rr', 'km', myThid ) #endif - + RETURN END !SUBROUTINE WriteRcvrRanges !********************************************************************! - + #ifdef IHOP_THREED SUBROUTINE WriteRcvrBearings( myThid ) ! for 3D bellhop @@ -493,7 +493,7 @@ SUBROUTINE WriteRcvrBearings( myThid ) ! for 3D bellhop ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == ! IEsco23: NOT SUPPORTED IN ihop @@ -516,22 +516,22 @@ SUBROUTINE WriteVector( Nx, x, Description, Units, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == INTEGER, INTENT( IN ) :: Nx REAL (KIND=_RL90), INTENT( INOUT ) :: x( : ) CHARACTER, INTENT( IN ) :: Description*( * ), Units*( * ) INTEGER :: ix - + #ifdef IHOP_WRITE_OUT ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.GE.0) THEN - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)')'______________________________________________', & '_____________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A,I10)') 'Number of ' // Description // ' = ', Nx CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -547,7 +547,7 @@ SUBROUTINE WriteVector( Nx, x, Description, Units, myThid ) CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) END IF - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) ENDIF #endif /* IHOP_WRITE_OUT */ diff --git a/src/ssp_mod.F90 b/src/ssp_mod.F90 index 836846c..3a1b720 100644 --- a/src/ssp_mod.F90 +++ b/src/ssp_mod.F90 @@ -8,10 +8,10 @@ MODULE ssp_mod ! Holds SSP input by user and associated variables - ! This module is very similar to the one used by the other programs in the + ! This module is very similar to the one used by the other programs in the ! Acoustics Toolbox. However, it returns the SSP *and* its derivatives - ! Also, a greater premium has been placed on returning this info quickly, + ! Also, a greater premium has been placed on returning this info quickly, ! since BELLHOP calls it at every step so more information is pre-computed USE ihop_mod, only: PRTFile @@ -63,8 +63,8 @@ MODULE ssp_mod betaI = 0, rhoR = 1 ! SSP interpolation parameters, only used in ssp_mod COMPLEX (KIND=_RL90) :: n2(MaxSSP), n2z(MaxSSP) - COMPLEX (KIND=_RL90) :: cSpln( 4, MaxSSP ), cCoef( 4, MaxSSP ) - + COMPLEX (KIND=_RL90) :: cSpln( 4, MaxSSP ), cCoef( 4, MaxSSP ) + ! TYPE STRUCTURES ! == Type Structures == TYPE rxyz_vector @@ -95,8 +95,8 @@ MODULE ssp_mod !**********************************************************************! SUBROUTINE initSSP( x, myThid ) - ! Call the particular profile routine indicated by the SSP%Type and - ! perform initialize SSP structures + ! Call the particular profile routine indicated by the SSP%Type and + ! perform initialize SSP structures ! USE ihop_mod, only: SSPFile ! USE pchip_mod, only: PCHIP ! USE splinec_mod,only: cspline @@ -105,7 +105,7 @@ SUBROUTINE initSSP( x, myThid ) ! myThid :: Thread number. Unused by IESCO INTEGER, INTENT( IN ) :: myThid ! CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point ! INTEGER :: ir, iz @@ -129,12 +129,12 @@ SUBROUTINE initSSP( x, myThid ) RETURN END !SUBROUTINE initSSP - + !**********************************************************************! SUBROUTINE setSSP( x, myThid ) - ! Call the particular profile routine indicated by the SSP%Type and - ! set SSP structures + ! Call the particular profile routine indicated by the SSP%Type and + ! set SSP structures USE pchip_mod, only: PCHIP USE splinec_mod,only: cspline @@ -144,7 +144,7 @@ SUBROUTINE setSSP( x, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point INTEGER :: ir, iz @@ -189,17 +189,17 @@ SUBROUTINE setSSP( x, myThid ) ! compute coefficients of std cubic polynomial: c0 + c1*x + c2*x + c3*x ! CALL PCHIP( SSP%z, SSP%c, SSP%NPts, cCoef, cSpln ) -!IEsco23 Test this: +!IEsco23 Test this: ! CALL PCHIP( SSP%z, SSP%c, SSP%Nz, cCoef, cSpln ) CASE ( 'S' ) ! Cubic spline profile option cSpln( 1, 1:SSP%NPts ) = SSP%c( 1:SSP%NPts ) -!IEsco23 Test this: +!IEsco23 Test this: ! cSpln( 1, 1 : SSP%Nz ) = SSP%c( 1 : SSP%Nz ) - + ! Compute spline coefs CALL cSpline( SSP%z, cSpln( 1, 1 ), SSP%NPts, 0, 0, SSP%NPts ) -!IEsco23 Test this: +!IEsco23 Test this: ! CALL CSpline( SSP%z, cSpln( 1,1 ), SSP%Nz,iBCBeg, iBCEnd, SSP%Nz ) CASE ( 'Q' ) @@ -223,19 +223,19 @@ SUBROUTINE setSSP( x, myThid ) RETURN END !SUBROUTINE setSSP - + !**********************************************************************! SUBROUTINE evalSSP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) - ! Call the particular profile routine indicated by the SSP%Type and - ! tabulate cp, cs, rhoT + ! Call the particular profile routine indicated by the SSP%Type and + ! tabulate cp, cs, rhoT ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, rho @@ -272,7 +272,7 @@ SUBROUTINE evalSSP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) RETURN END !SUBROUTINE evalSSP - + !**********************************************************************! SUBROUTINE n2Linear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) @@ -282,17 +282,17 @@ SUBROUTINE n2Linear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO INTEGER, INTENT( IN ) :: myThid - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x( 2 ) ! r-z SSP evaluation point REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc( 2 ), crr, crz, czz, & rho ! sound speed and its derivatives - - + + iSegz = 1 !RG IF ( x( 2 ) < SSP%z( iSegz ) .OR. x( 2 ) > SSP%z( iSegz+1 ) ) THEN foundz=.false. -!IEsco23 Test this: +!IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths IF ( x( 2 ) < SSP%z( iz ) .and. .not. foundz ) THEN @@ -326,16 +326,16 @@ SUBROUTINE cLinear( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO INTEGER, INTENT( IN ) :: myThid - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point ! sound speed and its derivatives REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, rho - + iSegz = 1 !RG IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. -!IEsco23 Test this: +!IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN @@ -368,7 +368,7 @@ SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO INTEGER, INTENT( IN ) :: myThid - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, & @@ -380,7 +380,7 @@ SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) iSegz = 1 !RG IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. -!IEsco23 Test this: +!IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN @@ -410,7 +410,7 @@ SUBROUTINE cPCHIP( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) W = ( x(2) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) ! linear interp of density - rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) + rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) RETURN END !SUBROUTINE cPCHIP @@ -425,7 +425,7 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO INTEGER, INTENT( IN ) :: myThid - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, & @@ -438,7 +438,7 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) iSegz = 1 !RG IF ( x(2) < SSP%z( iSegz ) .OR. x(2) > SSP%z( iSegz+1 ) ) THEN foundz=.false. -!IEsco23 Test this: +!IEsco23 Test this: ! DO iz = 2, SSP%Nz ! Search for bracketting Depths DO iz = 2, SSP%NPts ! Search for bracketting Depths IF ( x(2) < SSP%z( iz ) .and. .not. foundz ) THEN @@ -469,13 +469,13 @@ SUBROUTINE cCubic( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) !**********************************************************************! SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) ! Bilinear quadrilatteral interpolation of SSP data in 2D, SSP%Type = 'Q' - + ! == Routine Arguments == ! myThid :: Thread number. Unused by IESCO ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT( IN ) :: x(2) ! r-z SSP evaluation point REAL (KIND=_RL90), INTENT( OUT ) :: c, cimag, gradc(2), crr, crz, czz, & @@ -483,9 +483,9 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) INTEGER :: irT, iz2 INTEGER :: isegzold REAL (KIND=_RL90) :: c1, c2, cz1, cz2, cr, cz, s1, s2, delta_r, delta_z - + ! *** Section to return SSP info *** - + ! IESCO22: iSegz is the depth index containing x depth ! find depth-layer where x(2) in ( SSP%z( iSegz ), SSP%z( iSegz+1 ) ) iSegz = 1 !RG @@ -498,7 +498,7 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) END IF END DO END IF - + ! Check that x is inside the box where the sound speed is defined IF ( x(1) < SSP%Seg%r( 1 ) .OR. x(1) > SSP%Seg%r( SSP%Nr ) ) THEN #ifdef IHOP_WRITE_OUT @@ -516,7 +516,7 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R Quad' END IF - + ! find range-segment where x(1) in [ SSP%Seg%r( iSegr ), SSP%Seg%r( iSegr+1 ) ) iSegr = 1 !RG IF ( x(1) < SSP%Seg%r( iSegr ) .OR. x(1) >= SSP%Seg%r( iSegr+1 ) ) THEN @@ -528,13 +528,13 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) END IF END DO END IF - + ! for depth, x(2), get the sound speed at both ends of range segment cz1 = SSP%czMat( iSegz, iSegr ) cz2 = SSP%czMat( iSegz, iSegr+1 ) - + !IESCO22: s2 is distance btwn field point, x(2), and ssp depth @ iSegz - s2 = x(2) - SSP%z( iSegz ) + s2 = x(2) - SSP%z( iSegz ) delta_z = SSP%z( iSegz+1 ) - SSP%z( iSegz ) IF (delta_z <= 0 .OR. s2 > delta_z) THEN #ifdef IHOP_WRITE_OUT @@ -546,37 +546,37 @@ SUBROUTINE Quad( x, c, cimag, gradc, crr, crz, czz, rho, myThid ) #endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R Quad' END IF - + c1 = SSP%cMat( iSegz, iSegr ) + s2*cz1 c2 = SSP%cMat( iSegz, iSegr+1 ) + s2*cz2 - + ! s1 = proportional distance of x(1) in range delta_r = SSP%Seg%r( iSegr+1 ) - SSP%Seg%r( iSegr ) s1 = ( x(1) - SSP%Seg%r( iSegr ) ) / delta_r ! piecewise constant extrapolation for ranges outside SSP box s1 = MIN( s1, 1.0D0 ) s1 = MAX( s1, 0.0D0 ) - + c = ( 1.0D0-s1 )*c1 + s1*c2 ! c @ x - + ! interpolate the attenuation !!!! SSP in ENVFile needs to match first column of SSPFile s2 = s2 / delta_z ! normalize depth layer ! volume attenuation is taken from the single c(z) profile - cimag = AIMAG( ( 1.0D0-s2 )*SSP%c( iSegz ) + s2*SSP%c( iSegz+1 ) ) - + cimag = AIMAG( ( 1.0D0-s2 )*SSP%c( iSegz ) + s2*SSP%c( iSegz+1 ) ) + cz = ( 1.0D0-s1 )*cz1 + s1*cz2 ! cz @ x - + cr = ( c2 - c1 ) / delta_r ! SSP grid cr crz = ( cz2 - cz1 ) / delta_r ! SSP grid crz - + gradc = [ cr, cz ] crr = 0.0 czz = 0.0 - + ! linear interpolation for density W = ( x(2) - SSP%z( iSegz ) ) / ( SSP%z( iSegz+1 ) - SSP%z( iSegz ) ) rho = ( 1.0D0-W ) * SSP%rho( iSegz ) + W * SSP%rho( iSegz+1 ) - + !IESCO22: for thesis, czz=crr=0, and rho=1 at all times RETURN END !SUBROUTINE Quad @@ -598,7 +598,7 @@ SUBROUTINE ReadSSP( Depth, myThid ) ! msgBuf :: Used to build messages for printing. INTEGER, INTENT( IN ) :: myThid CHARACTER*(MAX_LEN_MBUF):: msgBuf - + ! == Local Variables == REAL (KIND=_RL90), INTENT(IN) :: Depth REAL (KIND=_RL90) :: bPower, fT @@ -650,7 +650,7 @@ SUBROUTINE ReadSSP( Depth, myThid ) CLOSE( SSPFile ) SSP%NPts = 1 - DO iz = 1, MaxSSP + DO iz = 1, MaxSSP alphaR = SSP%cMat( iz, 1 ) SSP%c(iz) = CRCI( SSP%z(iz), alphaR, alphaI, SSP%AttenUnit, bPower, fT, & @@ -687,13 +687,13 @@ SUBROUTINE ReadSSP( Depth, myThid ) ! Write to PRTFile CALL writeSSP( myThid ) - + RETURN ENDIF SSP%NPts = SSP%NPts + 1 END DO - + ! Fall through means too many points in the profile #ifdef IHOP_WRITE_OUT WRITE(msgBuf,'(2A)') 'SSPMOD ReadSSP: ', & @@ -758,7 +758,7 @@ SUBROUTINE ExtractSSP( Depth, myThid ) ! Initiate to ceros tmpSSP = 0.0 _d 0 - ! interpolate SSP with adaptive IDW from gcm grid to ihop grid + ! interpolate SSP with adaptive IDW from gcm grid to ihop grid DO bj=myByLo(myThid),myByHi(myThid) DO bi=myBxLo(myThid),myBxHi(myThid) !$TAF INIT tape_ssp1 = static, 100 !RG @@ -828,7 +828,7 @@ SUBROUTINE ExtractSSP( Depth, myThid ) END DO !jj END DO !ii END DO !i - END DO !j + END DO !j END DO !bi END DO !bj @@ -902,16 +902,16 @@ SUBROUTINE writeSSP( myThid ) WRITE(msgBuf,'(2A)')'________________________________________________', & '___________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') "Sound Speed Field" + WRITE(msgBuf,'(A)') "Sound Speed Field" CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(2A)') 'Profile option: ', SSP%Type CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) IF (SSP%Nr .GT. 1) THEN @@ -928,16 +928,16 @@ SUBROUTINE writeSSP( myThid ) WRITE(msgBuf,'(A,I10)') 'Number of SSP depths = ', SSP%Nz CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Profile ranges [km]:' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(fmtStr,'(A,I10,A)') '(T11,',SSP%Nr, 'F10.2)' ssptmp = SSP%Seg%R( 1:SSP%Nr ) / 1000.0 - WRITE(msgBuf,fmtStr) ssptmp + WRITE(msgBuf,fmtStr) ssptmp CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Sound speed matrix:' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -952,7 +952,7 @@ SUBROUTINE writeSSP( myThid ) END DO IF (useSSPFile) THEN - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) WRITE(msgBuf,'(A)') 'Sound speed profile:' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) @@ -962,11 +962,11 @@ SUBROUTINE writeSSP( myThid ) WRITE(msgBuf,'(2A)')' [m] [m/s] [m/s] [g/cm^3] ', & ' [m/s] [m/s]' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - + WRITE(msgBuf,'(2A)')'_______________________________________________', & '____________' CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) - WRITE(msgBuf,'(A)') + WRITE(msgBuf,'(A)') CALL PRINT_MESSAGE( msgbuf, PRTFile, SQUEEZE_RIGHT, myThid ) DO iz = 1, SSP%NPts @@ -1018,7 +1018,7 @@ SUBROUTINE init_fixed_ssp( myThid ) SSP%cz = (-999.0, 0.0) ! set ihop SSP grid size - SSP%Nz = Nr+2 ! add z=0 z=Depth layers to GCM Nr + SSP%Nz = Nr+2 ! add z=0 z=Depth layers to GCM Nr SSP%Nr = IHOP_NPTS_RANGE SSP%NPts = SSP%Nz @@ -1038,7 +1038,7 @@ SUBROUTINE init_fixed_ssp( myThid ) # endif /* IHOP_WRITE_OUT */ STOP 'ABNORMAL END: S/R init_fixed_SSP' END IF - + SSP%Seg%r( 1:SSP%Nr ) = ihop_ranges( 1:SSP%Nr ) ! Modify from [m] to [km] SSP%Seg%r = 1000.0 * SSP%Seg%r @@ -1065,7 +1065,7 @@ SUBROUTINE init_fixed_ssp( myThid ) ! Sum IDW weights DO ii = 1, SSP%Nr ihop_sumweights(ii,:) = sum(ihop_idw_weights(ii,:)) - END DO + END DO ! Adapt IDW interpolation by bathymetry DO bj=myByLo(myThid),myByHi(myThid) @@ -1074,7 +1074,7 @@ SUBROUTINE init_fixed_ssp( myThid ) DO i=1,sNx DO ii=1, SSP%Nr skip_range = .FALSE. - + DO jj=1,IHOP_npts_idw IF (ABS(xC(i, j, bi, bj) - ihop_xc(ii, jj)) .LE. tolerance .AND. & ABS(yC(i, j, bi, bj) - ihop_yc(ii, jj)) .LE. tolerance) THEN @@ -1083,12 +1083,12 @@ SUBROUTINE init_fixed_ssp( myThid ) IF (nii(ii) .EQ. 1 .AND. k .GT. njj(ii)) THEN skip_range = .TRUE. END IF - + IF (.NOT. skip_range) THEN IF (hFacC(i, j, k, bi, bj) .EQ. 0.0) THEN ihop_sumweights(ii, k) = & ihop_sumweights(ii, k) - ihop_idw_weights(ii, jj) - + ! No interpolation on xc, yc centered ranges IF (ihop_idw_weights(ii, jj) .EQ. 0.0) THEN ihop_sumweights(ii, k:Nr) = 0.0 @@ -1096,7 +1096,7 @@ SUBROUTINE init_fixed_ssp( myThid ) njj(ii) = k END IF END IF - + ! Set TINY and negative values to 0.0 IF (ihop_sumweights(ii, k) .LT. 1D-13) ihop_sumweights(ii, k) = 0.0 END IF diff --git a/src/step.F90 b/src/step.F90 index c4ff5c0..1b6fbfc 100644 --- a/src/step.F90 +++ b/src/step.F90 @@ -51,12 +51,12 @@ SUBROUTINE Step2D( ray0, ray2, Topx, Topn, Botx, Botn, myThid ) c2, cimag2, crr2, crz2, czz2, & urayt0( 2 ), urayt1( 2 ), & h, halfh, hw0, hw1, ray2n( 2 ), RM, RN, & - gradcjump( 2 ), cnjump, csjump, w0, w1, rho + gradcjump( 2 ), cnjump, csjump, w0, w1, rho - ! The numerical integrator used here is a version of the polygon (a.k.a. + ! The numerical integrator used here is a version of the polygon (a.k.a. ! midpoint, leapfrog, or Box) method, and similar ! to the Heun (second order Runge-Kutta method). - ! However, it's modified to allow for a dynamic step change, while + ! However, it's modified to allow for a dynamic step change, while ! preserving the second-order accuracy. ! *** Phase 1 (an Euler step) @@ -74,7 +74,7 @@ SUBROUTINE Step2D( ray0, ray2, Topx, Topn, Botx, Botn, myThid ) ! reduce h to land on boundary CALL ReduceStep2D( ray0%x, urayt0, iSegz0, iSegr0, Topx, Topn, Botx, & - Botn, h ) + Botn, h ) halfh = 0.5 * h ! first step of the modified polygon method is a half step ! Euler march forward @@ -83,7 +83,7 @@ SUBROUTINE Step2D( ray0, ray2, Topx, Topn, Botx, Botn, myThid ) ray1%p = ray0%p - halfh * cnn0_csq0 * ray0%q ray1%q = ray0%q + halfh * c0 * ray0%p !IESCO22: q /= 0 for 'G' beam - ! *** Phase 2 (update step size, and Polygon march forward) + ! *** Phase 2 (update step size, and Polygon march forward) CALL evalSSP( ray1%x, c1, cimag1, gradc1, crr1, crz1, czz1, rho, myThid ) csq1 = c1 * c1 @@ -92,7 +92,7 @@ SUBROUTINE Step2D( ray0, ray2, Topx, Topn, Botx, Botn, myThid ) ! BUG: The Munk test case with a horizontally launched ray caused problems. ! The ray vertexes on an interface and can ping-pong around that interface. - ! Have to be careful in that case about big changes to the stepsize (that + ! Have to be careful in that case about big changes to the stepsize (that ! invalidate the leap-frog scheme) in phase II. ! A modified Heun or Box method could also work. @@ -151,7 +151,7 @@ END SUBROUTINE Step2D SUBROUTINE ReduceStep2D( x0, urayt, iSegz0, iSegr0, Topx, Topn, Botx, Botn, h ) - ! calculate a reduced step size, h, that lands on any points where the + ! calculate a reduced step size, h, that lands on any points where the ! environment leaves water USE ihop_mod, only: iSmallStepCtr USE bdry_mod, only: rTopSeg, rBotSeg @@ -161,19 +161,19 @@ SUBROUTINE ReduceStep2D( x0, urayt, iSegz0, iSegr0, Topx, Topn, Botx, Botn, h ) REAL (KIND=_RL90), INTENT( IN ) :: x0( 2 ), urayt( 2 ) ! Top, bottom coordinate and normal REAL (KIND=_RL90), INTENT( IN ) :: Topx( 2 ), Topn( 2 ) - REAL (KIND=_RL90), INTENT( IN ) :: Botx( 2 ), Botn( 2 ) - REAL (KIND=_RL90), INTENT( INOUT ) :: h ! reduced step size + REAL (KIND=_RL90), INTENT( IN ) :: Botx( 2 ), Botn( 2 ) + REAL (KIND=_RL90), INTENT( INOUT ) :: h ! reduced step size REAL (KIND=_RL90) :: hInt, hTop, hBot, hSeg, & hBoxr, hBoxz ! trial step sizes REAL (KIND=_RL90) :: x( 2 ), d( 2 ), d0( 2 ), rSeg( 2 ) - ! Detect interface or boundary crossing and reduce step, if necessary, to + ! Detect interface or boundary crossing and reduce step, if necessary, to ! land on that crossing. ! Keep in mind possibility that user put source right on an interface - ! and that multiple events can occur (crossing interface, top, and bottom + ! and that multiple events can occur (crossing interface, top, and bottom ! in a single step). -!$TAF init reducestep2d = static, 50 +!$TAF init reducestep2d = static, 50 !$TAF store h = reducestep2d @@ -231,10 +231,10 @@ SUBROUTINE ReduceStep2D( x0, urayt, iSegz0, iSegr0, Topx, Topn, Botx, Botn, h ) ! ray mask using a box centered at ( 0, 0 ) hBoxr = huge( hBoxr ) hBoxz = huge( hBoxz ) - + IF ( ABS( x( 1 ) ) > Beam%Box%r ) hBoxr = ( Beam%Box%r - ABS( x0( 1 ) ) ) / ABS( urayt( 1 ) ) IF ( ABS( x( 2 ) ) > Beam%Box%z ) hBoxz = ( Beam%Box%z - ABS( x0( 2 ) ) ) / ABS( urayt( 2 ) ) - + h = MIN( h, hInt, hTop, hBot, hSeg, hBoxr, hBoxz ) ! take limit set by shortest distance to a crossing IF ( h < 1.0d-4 * Beam%deltas ) THEN ! is it taking an infinitesimal step? h = 1.0d-4 * Beam%deltas ! make sure we make some motion diff --git a/src/writeray.F90 b/src/writeray.F90 index 7dddf53..018931f 100644 --- a/src/writeray.F90 +++ b/src/writeray.F90 @@ -6,7 +6,7 @@ MODULE writeRay ! Ivana Escobar ! - ! Compress the ray data keeping every iSkip point, points near surface or + ! Compress the ray data keeping every iSkip point, points near surface or ! bottom, and last point. ! Write to RAYFile. @@ -35,7 +35,7 @@ MODULE writeRay !======================================================================= - INTEGER, PRIVATE :: MaxNRayPoints = 50000 ! this is the maximum length of + INTEGER, PRIVATE :: MaxNRayPoints = 50000 ! this is the maximum length of ! the ray vector that is written out INTEGER, PRIVATE :: is, N2, iSkip @@ -49,14 +49,14 @@ SUBROUTINE WriteRay2D( alpha0, Nsteps1 ) ! In adjoint mode we do not write output besides on the first run IF (IHOP_dumpfreq.LT.0) RETURN - + ! compression N2 = 1 iSkip = MAX( Nsteps1 / MaxNRayPoints, 1 ) Stepping: DO is = 2, Nsteps1 - ! ensure that we always write ray points near bdry reflections (works + ! ensure that we always write ray points near bdry reflections (works ! only for flat bdry) IF ( MIN( Bdry%Bot%HS%Depth - ray2D( is )%x( 2 ), & ray2D( is )%x( 2 ) - Bdry%Top%HS%Depth ) < 0.2 .OR. & @@ -98,7 +98,7 @@ SUBROUTINE WriteDel2D( alpha0, Nsteps1 ) iSkip = MAX( Nsteps1 / MaxNRayPoints, 1 ) Stepping: DO is = 2, Nsteps1 - ! ensure that we always write ray points near bdry reflections (works + ! ensure that we always write ray points near bdry reflections (works ! only for flat bdry) IF ( MIN( Bdry%Bot%HS%Depth - ray2D( is )%x( 2 ), & ray2D( is )%x( 2 ) - Bdry%Top%HS%Depth ) < 0.2 .OR. &