├── ROMSPath.f90 ├── ROMSPATH_MANUAL.docx ├── README.md ├── growth_module.f90 ├── norm_module.f90 ├── pdf_module.f90 ├── hor_turb_module.f90 ├── makefile ├── parameter_module.f90 ├── ver_turb_module.f90 ├── advection_module.f90 ├── random_module.f90 ├── ROMSPath.data ├── boundary_module.f90 ├── CROCO ├── grid_module.f90 └── hydrodynamic_module.f90 ├── ROMSPath.h ├── grid_module.f90 ├── hydrodynamic_module.f90 └── behavior_module.f90 /ROMSPath.f90: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/imcslatte/ROMSPath/HEAD/ROMSPath.f90 -------------------------------------------------------------------------------- /ROMSPATH_MANUAL.docx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/imcslatte/ROMSPath/HEAD/ROMSPATH_MANUAL.docx -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ROMSPath 2 | Offline particle tracking (OPT) is a widely used tool for the analysis of data in oceanographic research. Given the output of a hydrodynamic model, OPT can provide answers to a wide variety of research questions involving fluid kinematics, zooplankton transport, the dispersion of pollutants, and the fate of chemical tracers, among others. In this paper, we introduce ROMSPath, an OPT model designed to complement the Regional Ocean Modelling System (ROMS). Based on the Lagrangian TRANSport (LTRANS) model (North et al., 2008), ROMSPath is written in Fortran 90 and provides advancements in functionality and efficiency compared to LTRANS. First, ROMSPath now calculates particle trajectories using the ROMS native grid, which provides advantages in interpolation, masking, and boundary interaction, while improving accuracy. Second, ROMSPath enables simulated particles to pass between nested ROMS grids, which are an increasingly popular tool to simulate the ocean over multiple scales. Third, the ROMSPath vertical turbulence module enables the turbulent (diffusion) time step and advection time step to be specified separately, adding flexibility and improving computational efficiency. Lastly, ROMSPath includes new infrastructure enabling input of auxiliary parameters for added functionality. In particular, Stokes drift can be input and added to particle advection. Here we describe the details of these updates and improvements. 3 | -------------------------------------------------------------------------------- /growth_module.f90: -------------------------------------------------------------------------------- 1 | MODULE GROWTH_MOD 2 | 3 | ! GRowTH MODULE 4 | ! 5 | ! Growth algorithms and code created by: Heidi FUchs, implemented by Elias Hunter, 6 | ! Created on: 2019 7 | ! Last Modified on: 22 March 2019 8 | ! ROMSPath Version: 1.0.1 9 | 10 | IMPLICIT NONE 11 | PRIVATE 12 | SAVE 13 | 14 | 15 | !The following procedures have been made public: 16 | PUBLIC :: growlarva 17 | 18 | CONTAINS 19 | 20 | 21 | 22 | SUBROUTINE growlarva(P_temp,P_salt,P_age,P_size,P_status) !Update particle status 23 | 24 | USE PARAM_MOD, ONLY: Growth,mortality,deadage,initsize,maxsize, & 25 | a0,a1,a2,a3,a4,a5,a6,a7,a8,idt,tempcut 26 | IMPLICIT NONE 27 | 28 | 29 | DOUBLE PRECISION, INTENT(IN) ::P_salt,P_temp,P_age 30 | DOUBLE PRECISION, INTENT(INOUT) ::P_size,P_status 31 | DOUBLE PRECISION :: GR,DS 32 | 33 | if (Growth.eq. 1) then 34 | if (P_age.ge.deadage) then 35 | P_status=9.0 36 | endif 37 | elseif (Growth.eq. 2) then 38 | 39 | if (P_temp.gt.tempcut) then 40 | GR = a0 + a1*P_temp + a2*P_salt + a3*P_temp*P_salt & 41 | + a4*(P_temp**2) + a5*(P_salt**2) + a6*(P_temp**2)*P_salt + & 42 | a7*P_temp*(P_salt**2) + a8*(P_temp**2)*(P_salt**2) 43 | if (GR.LT.0.0) then 44 | GR=0.0 45 | endif 46 | else 47 | GR=0.0 48 | endif 49 | 50 | 51 | 52 | DS=GR*DBLE(idt)/86400.0D0 53 | P_size=P_size+DS 54 | endif 55 | 56 | 57 | END SUBROUTINE growlarva 58 | 59 | 60 | 61 | 62 | END MODULE GROWTH_MOD 63 | -------------------------------------------------------------------------------- /norm_module.f90: -------------------------------------------------------------------------------- 1 | MODULE PDF_MOD 2 | 3 | ! The Norm Module contains the function Norm, which returns a random number 4 | ! (deviate) drawn from a normal distribution with zero mean and unit 5 | ! variance (i.e., standard deviation = 1). 6 | ! 7 | ! Created by: Elizabeth North 8 | ! Modified by: Zachary Schlag 9 | ! Created on: 22 Aug 2008 10 | ! Last Modified on: Feb 2011 11 | ! ROMSPath Version: 1.0.1 12 | 13 | IMPLICIT NONE 14 | PUBLIC 15 | 16 | CONTAINS 17 | 18 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 19 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 20 | ! ~~ ~~ 21 | ! ~~ FUNCTION norm ~~ 22 | ! ~~ ~~ 23 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 24 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 25 | 26 | DOUBLE PRECISION FUNCTION norm() 27 | ! This function returns a normally distributed deviate with 28 | ! zero mean and unit variance (i.e., standard deviation = 1). 29 | ! By E. North, 8/22/08 30 | USE PARAM_MOD, ONLY: PI 31 | USE RANDOM_MOD, ONLY: genrand_real3 32 | IMPLICIT NONE 33 | 34 | DOUBLE PRECISION :: dev1,dev2 35 | 36 | dev1 = genrand_real3() 37 | dev2 = genrand_real3() 38 | norm = sqrt(DBLE(-2.)*log(dev1)) * cos(DBLE(2.)*PI*dev2) 39 | 40 | END FUNCTION norm 41 | 42 | END MODULE NORM_MOD -------------------------------------------------------------------------------- /pdf_module.f90: -------------------------------------------------------------------------------- 1 | MODULE PDF_MOD 2 | 3 | ! The Norm Module contains the function Norm, which returns a random number 4 | ! (deviate) drawn from a normal distribution with zero mean and unit 5 | ! variance (i.e., standard deviation = 1). 6 | ! 7 | ! Created by: Elizabeth North 8 | ! Modified by: Zachary Schlag 9 | ! Created on: 22 Aug 2008 10 | ! Last Modified on: Feb 2011 11 | ! ROMSPath Version: 1.0.1 12 | 13 | IMPLICIT NONE 14 | PUBLIC 15 | 16 | CONTAINS 17 | 18 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 19 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 20 | ! ~~ ~~ 21 | ! ~~ FUNCTION norm ~~ 22 | ! ~~ ~~ 23 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 24 | ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 25 | 26 | DOUBLE PRECISION FUNCTION norm() 27 | ! This function returns a normally distributed deviate with 28 | ! zero mean and unit variance (i.e., standard deviation = 1). 29 | ! By E. North, 8/22/08 30 | USE PARAM_MOD, ONLY: PI 31 | USE RANDOM_MOD, ONLY: genrand_real3 32 | IMPLICIT NONE 33 | 34 | DOUBLE PRECISION :: dev1,dev2 35 | 36 | dev1 = genrand_real3() 37 | dev2 = genrand_real3() 38 | norm = sqrt(DBLE(-2.)*log(dev1)) * cos(DBLE(2.)*PI*dev2) 39 | 40 | END FUNCTION norm 41 | 42 | 43 | DOUBLE PRECISION FUNCTION laplace() 44 | ! This function returns a normally distributed deviate with 45 | ! zero mean and unit variance (i.e., standard deviation = 1). 46 | ! By E. North, 8/22/08 47 | USE PARAM_MOD, ONLY: PI 48 | USE RANDOM_MOD, ONLY: genrand_real3 49 | IMPLICIT NONE 50 | 51 | DOUBLE PRECISION :: dev1,dev2 52 | 53 | dev1 = genrand_real3()-0.5D0 54 | dev2=-1.0D0*log(1.0D0- (2.0D0* ABS(dev1)))/sqrt(2.0D0); 55 | laplace = sign(dev2,dev1) 56 | END FUNCTION laplace 57 | 58 | END MODULE PDF_MOD -------------------------------------------------------------------------------- /hor_turb_module.f90: -------------------------------------------------------------------------------- 1 | MODULE HTURB_MOD 2 | 3 | ! A random walk model is used to simulate turbulent particle motion in the 4 | ! horizontal direction (x- and y- directions). 5 | ! 6 | ! Created by: Elizabeth North 7 | ! Modified by: Zachary Schlag 8 | ! Created on: 2003 9 | ! Last Modified on: 18 Aug 2008 10 | ! ROMSPath Version: 1.0.1 11 | 12 | IMPLICIT NONE 13 | PUBLIC 14 | 15 | CONTAINS 16 | 17 | ! ***************** Horizontal Turbulence (RWM) ********************* 18 | ! *********************************************************************** 19 | ! ** Random Walk Model (Visser 1997 MEPS 158:275-281) for simulating ** 20 | ! ** turbulent diffusion, applied in the horizontal direction ** 21 | ! ** z(t+1)= z + R[2/r K(z)dt]**0.5 ** 22 | ! ** where z = particle vertical location at time t ** 23 | ! ** K = horizontal diffusivity (KM from QUODDY) ** 24 | ! ** dt = time step of RWM (deltat) ** 25 | ! ** R = random process with mean = 0 and standard deviation = r. ** 26 | ! ** ** 27 | ! ** Programmed by EW North February 2003 UMCES HPL enorth@hpl.umces.edu ** 28 | ! ************************************************************************* 29 | 30 | SUBROUTINE HTurb(TurbHx,TurbHy,ng) 31 | USE PARAM_MOD, ONLY: ConstantHTurb,idt 32 | USE PDF_MOD, ONLY: norm 33 | IMPLICIT NONE 34 | 35 | DOUBLE PRECISION, INTENT(OUT) :: TurbHx,TurbHy 36 | INTEGER, INTENT(in) ::ng 37 | DOUBLE PRECISION :: devX,devY,r 38 | DOUBLE PRECISION :: KM 39 | 40 | r=1.0 ! standard deviation of the random deviate 41 | KM=ConstantHTurb(ng) ! constant horizontal diffusivity 42 | 43 | devX=norm() ! the random deviate in the X direction 44 | devY=norm() ! the random deviate in the Y direction 45 | 46 | !Apply random walk model to calculate horizontal turbulent 47 | ! particle displacement 48 | TurbHx= devX*(DBLE(2.0)/r * KM *idt)**0.5 49 | TurbHy= devY*(DBLE(2.0)/r * KM *idt)**0.5 50 | 51 | END SUBROUTINE HTurb 52 | 53 | END MODULE HTURB_MOD 54 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 2 | # ::: 3 | # ROMSPath Makefile ::: 4 | # ::: 5 | #:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 6 | 7 | 8 | #========================================================================== 9 | # USER-DEFINED OPTIONS = 10 | #========================================================================== 11 | 12 | #CPPFLAGS = -DGROWTH -DWETDRY -DSTOKES 13 | #CPPFLAGS = -DWETDRY 14 | 15 | #------------------------------------------------ 16 | # Set compiler and flags 17 | #------------------------------------------------ 18 | # 19 | # Turn one of the following on: 20 | IFORT:= 21 | GFORTRAN := on 22 | PGI := 23 | 24 | ifdef IFORT 25 | FC = ifort 26 | 27 | CPPFLAGS += -DIFORT 28 | FFLAGS = -fp-model strict -mcmodel=medium -O3 -fpp $(CPPFLAGS) -I$(NETCDF_INCDIR) 29 | # FFLAGS = -g -O0 -traceback -check all -check bounds -cpp $(CPPFLAGS) -I$(NETCDF_INCDIR) 30 | endif 31 | 32 | ifdef GFORTRAN 33 | FC = gfortran 34 | 35 | CPPFLAGS += -DGFORTRAN 36 | FFLAGS = -march=k8 -ffast-math -fno-cx-limited-range -O3 -funroll-loops --param max-unroll-times=4 -ffree-line-length-none -cpp $(CPPFLAGS) -I$(NETCDF_INCDIR) 37 | # FFLAGS = -g -O0 -ffree-line-length-none -cpp $(CPPFLAGS) -I$(NETCDF_INCDIR) 38 | endif 39 | 40 | ifdef PGI 41 | FC = pgf90 42 | CPPFLAGS += -DPGI 43 | # NETCDF_INCDIR = /home/rjdave/local/include 44 | # NETCDF_LIBDIR = /home/rjdave/local/lib 45 | FFLAGS := -g -cpp $(CPPFLAGS) -I$(NETCDF_INCDIR) 46 | endif 47 | 48 | #------------------------------------------------ 49 | # Set NetCDF Library Locations. 50 | # If NetCDF was compiled with HDF5, set: 51 | # HDF5 := on 52 | # Otherwise, leave blank: 53 | # HDF5 := 54 | #------------------------------------------------ 55 | 56 | HDF5 := on 57 | NFCONFIG := on 58 | #========================================================================== 59 | # End of user-defined options. Nothing should be changed below this point = 60 | #========================================================================== 61 | 62 | OBJS = parameter_module.o hydrodynamic_module.o grid_module.o \ 63 | random_module.o interpolation_module.o boundary_module.o\ 64 | pdf_module.o hor_turb_module.o pppack.o ver_turb_module.o advection_module.o\ 65 | growth_module.o behavior_module.o 66 | 67 | ifdef NFCONFIG 68 | NF_CONFIG ?= nf-config 69 | # ifdef GFORTRAN 70 | # NF_CONFIG ?= /opt/sw/apps/gcc-7.3.0/netcdf/4.6.1/bin/nf-config 71 | # endif 72 | # ifdef IFORT 73 | # NF_CONFIG ?= /opt/sw/apps/intel-18.0.1/netcdf/4.6.1/bin/nf-config 74 | # endif 75 | NETCDF_INCDIR ?= $(shell $(NF_CONFIG) --prefix)/include 76 | LIBS := $(shell $(NF_CONFIG) --flibs) 77 | else 78 | ifdef HDF5 79 | ifdef PGI_USGS 80 | LIBS = -L$(NETCDF_LIBDIR) -lnetcdf -lnetcdff -L/share/apps/hdf5/lib -lhdf5_hl -lhdf5 -lz -lm -L/share/apps/szip/lib -lsz -lcurl 81 | else 82 | LIBS = -L$(NETCDF_LIBDIR) -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lcurl -lz 83 | endif 84 | else 85 | LIBS = -L$(NETCDF_LIBDIR) -lnetcdff -lnetcdf 86 | endif 87 | 88 | endif 89 | 90 | ROMSPath : $(OBJS) 91 | 92 | @echo " Compiling ROMSPath.f90 " 93 | @echo " Using $(FC) " 94 | @echo " $(FC) $(FFLAGS) -o ROMSPath.exe ROMSPath.f90 $(OBJS) $(LIBS) -save-temps " 95 | @$(FC) $(FFLAGS) -o ROMSPath.exe ROMSPath.f90 $(OBJS) $(LIBS) -save-temps 96 | @echo " " 97 | @echo " Compilation Successfully Completed" 98 | @echo " " 99 | 100 | %.o: %.f90 101 | @echo " Compiling $<" 102 | @$(FC) $(FFLAGS) -cpp $(CPPFLAGS) -save-temps -c $< 103 | 104 | clean: 105 | \rm *.o *.mod *.i90 *.s *.exe 106 | 107 | -------------------------------------------------------------------------------- /parameter_module.f90: -------------------------------------------------------------------------------- 1 | MODULE PARAM_MOD 2 | 3 | ! The Parameter Module reads in the include file, ROMSPath.data, making the 4 | ! parameters declared within available to all the other modules. It also 5 | ! reads in information from the NetCDF grid file and calculates values of 6 | ! grid specific parameters, making them available to all the other modules. 7 | ! 8 | ! Created by: Zachary Schlag 9 | ! Created on: 28 Jul 2008 10 | ! Last Modified on: Feb 2013 11 | ! ROMSPath Version: 1.0.1 12 | 13 | IMPLICIT NONE 14 | PUBLIC 15 | SAVE 16 | 17 | include 'ROMSPath.h' 18 | 19 | CONTAINS 20 | 21 | 22 | SUBROUTINE getParams() 23 | !Subroutine to read all input parameters from ROMSPath.data 24 | 25 | character(len=120) :: header 26 | character(len=256) :: Iname 27 | integer :: istat,err 28 | 29 | err = 0 30 | 31 | CALL getarg(1,Iname) 32 | 33 | WRITE(6,*) '---------' 34 | WRITE(6,*) trim(Iname) 35 | WRITE(6,*) '----------' 36 | OPEN(1,file=Iname) !--- read control variables: 37 | ! OPEN(1,file='ROMSPath.data') !--- read control variables: 38 | 39 | 40 | 41 | IF(err == 0) THEN 42 | READ(1,nml=numparticles ,IOSTAT=istat) !--- number of particles 43 | IF(istat/=0)err = 10 44 | ENDIF 45 | IF(err == 0) THEN 46 | READ(1,nml=timeparam ,IOSTAT=istat) !--- time info 47 | IF(istat/=0)err = 20 48 | ENDIF 49 | IF(err == 0) THEN 50 | READ(1,nml=hydroparam ,IOSTAT=istat) !--- hydrodynamics info 51 | IF(istat/=0)err = 30 52 | ENDIF 53 | IF(err == 0) THEN 54 | READ(1,nml=turbparam ,IOSTAT=istat) !--- turbulence info 55 | IF(istat/=0)err = 40 56 | ENDIF 57 | IF(err == 0) THEN 58 | READ(1,nml=advectparam ,IOSTAT=istat) !--- Advection info 59 | IF(istat/=0)err = 45 60 | ENDIF 61 | IF(err == 0) THEN 62 | READ(1,nml=behavparam ,IOSTAT=istat) !--- behavior info 63 | IF(istat/=0)err = 50 64 | ENDIF 65 | IF(err == 0) THEN 66 | READ(1,nml=fuchsparam ,IOSTAT=istat) !--- FUCHS info 67 | IF(istat/=0)err = 55 68 | ENDIF 69 | IF(err == 0) THEN 70 | READ(1,nml=growparam ,IOSTAT=istat) !--- growth info 71 | IF(istat/=0)err = 60 72 | ENDIF 73 | IF(err == 0) THEN 74 | READ(1,nml=dvmparam ,IOSTAT=istat) !--- diurnal vertical migration 75 | IF(istat/=0)err = 60 76 | ENDIF 77 | IF(err == 0) THEN 78 | READ(1,nml=settleparam ,IOSTAT=istat) !--- settlement info 79 | IF(istat/=0)err = 70 80 | ENDIF 81 | IF(err == 0) THEN 82 | READ(1,nml=romsgrid ,IOSTAT=istat) !--- roms grid 83 | IF(istat/=0)err = 90 84 | ENDIF 85 | IF(err == 0) THEN 86 | READ(1,nml=romsoutput ,IOSTAT=istat) !--- roms history output file 87 | IF(istat/=0)err = 100 88 | ENDIF 89 | IF(err == 0) THEN 90 | READ(1,nml=parloc ,IOSTAT=istat) !--- particle locations 91 | IF(istat/=0)err = 110 92 | ENDIF 93 | IF(err == 0) THEN 94 | READ(1,nml=HabPolyLoc ,IOSTAT=istat) !--- habitat polygon info 95 | IF(istat/=0)err = 120 96 | ENDIF 97 | IF(err == 0) THEN 98 | READ(1,nml=output ,IOSTAT=istat) !--- output related info 99 | IF(istat/=0)err = 130 100 | ENDIF 101 | IF(err == 0) THEN 102 | READ(1,nml=other ,IOSTAT=istat) !--- other misc 103 | IF(istat/=0)err = 140 104 | ENDIF 105 | CLOSE(1) 106 | 107 | 108 | 109 | 110 | SELECT CASE(err) 111 | CASE(0) 112 | header='No Errors' 113 | CASE(10) 114 | header='Error when reading numparticles, pls check ROMSPath.data' 115 | CASE(20) 116 | header='Error when reading timeparam, pls check ROMSPath.data' 117 | CASE(30) 118 | header='Error when reading hydroparam, pls check ROMSPath.data' 119 | CASE(40) 120 | header='Error when reading turbparam, pls check ROMSPath.data' 121 | CASE(45) 122 | header='Error when reading advectparam, pls check ROMSPath.data' 123 | CASE(50) 124 | header='Error when reading behavparam, pls check ROMSPath.data' 125 | CASE(55) 126 | header='Error when reading fuchsparam, pls check ROMSPath.data' 127 | CASE(60) 128 | header='Error when reading growthparam, pls check ROMSPath.data' 129 | CASE(70) 130 | header='Error when reading settleparam, pls check ROMSPath.data' 131 | CASE(90) 132 | header='Error when reading romsgrid, pls check ROMSPath.data' 133 | CASE(100) 134 | header='Error when reading romsoutput, pls check ROMSPath.data' 135 | CASE(110) 136 | header='Error when reading parloc, pls check ROMSPath.data' 137 | CASE(120) 138 | header='Error when reading HabPolLoc, pls check ROMSPath.data' 139 | CASE(130) 140 | header='Error when reading output, pls check ROMSPath.data' 141 | CASE(140) 142 | header='Error when reading other, pls check ROMSPath.data' 143 | CASE(150) 144 | header='Error when reading gridinfo, pls check GRID.data' 145 | CASE DEFAULT 146 | header='Error: unexpected err number' 147 | END SELECT 148 | 149 | IF(err/=0) CALL errorHandler(Header,-1) !print the error message and stop 150 | 151 | 152 | END SUBROUTINE getParams 153 | 154 | 155 | SUBROUTINE errorHandler(header, flag) 156 | IMPLICIT NONE 157 | CHARACTER(LEN=120), INTENT(IN) :: header 158 | INTEGER, INTENT(IN) :: flag 159 | 160 | IF (flag .eq. -1) THEN 161 | WRITE(*,"(A120)")header !print error message in report.txt 162 | STOP 163 | ELSE 164 | WRITE(*,"('***** WARNING *****')") !print warning message to screen 165 | WRITE(*,"(A120)")header 166 | ENDIF 167 | 168 | END SUBROUTINE errorHandler 169 | 170 | 171 | END MODULE PARAM_MOD 172 | -------------------------------------------------------------------------------- /ver_turb_module.f90: -------------------------------------------------------------------------------- 1 | MODULE VTURB_MOD 2 | 3 | ! A random displacement model is implemented to simulate sub-grid scale 4 | ! turbulent particle motion in the vertical (z) direction. 5 | ! 6 | ! Created by: Elizabeth North 7 | ! Modified by: Zachary Schlag 8 | ! Created on: 2003 9 | ! Last Modified on: 18 Aug 2008 10 | ! ROMSPath Version: 1.0.1 11 | 12 | IMPLICIT NONE 13 | PUBLIC 14 | 15 | CONTAINS 16 | 17 | ! ********************** Vertical Turbulence ************************* 18 | ! *********************************************************************** 19 | ! ** Random Displacement Model (Visser 1997 MEPS 158:275-281) for ** 20 | ! ** simulating displacement due to turbulent diffusion ** 21 | ! ** (vertical direction) ** 22 | ! ** z(t+1)= z + K'(z)dt + R{ 2/r K[z+0.5K'(z)dt]dt}**0.5 ** 23 | ! ** where z = particle vertical location at time t ** 24 | ! ** K' = dK/dz (Kprime) and K = vertical diffusivity (KH from ROMS)** 25 | ! ** dt = time step of RDM (deltat) ** 26 | ! ** R = random process with mean = 0 and standard deviation = r. ** 27 | ! ** ** 28 | ! ** Programmed by EW North February 2003 UMCES HPL enorth@hpl.umces.edu ** 29 | ! ************************************************************************* 30 | 31 | SUBROUTINE VTurb(Xpar,Ypar,Zpar,ets,ex,ix,ng,TurbV) 32 | USE PARAM_MOD, ONLY: s_w,idt,t_b,t_c,t_f,serr,smth,sub,deltat,AKSback 33 | use grid_mod, only: getWlevel 34 | USE INT_MOD, ONLY: linint,polintd,getInterp3d,getInterp2D,getInterpAKs 35 | USE PDF_MOD, ONLY: norm 36 | 37 | ! USE TENSION_MOD, ONLY: TSPSI,HVAL,HPVAL 38 | IMPLICIT NONE 39 | real ( kind = 8 ) smooth,ppvalu 40 | 41 | INTEGER, INTENT(IN) :: ets 42 | DOUBLE PRECISION, INTENT(IN) :: Xpar,Ypar,Zpar,ex(3),ix(3) 43 | DOUBLE PRECISION, INTENT(OUT) :: TurbV 44 | 45 | 46 | 47 | DOUBLE PRECISION :: DEV,r,zetab,zetac,zetaf,zeta,zfit(4),KHfit(4),ast 48 | INTEGER :: i,j,k,jlo,loop,itop,ibot 49 | DOUBLE PRECISION :: tdepth,slopem,ParZc,Kprimec,KprimeZc,newZc,KH3rdc,Z3rdc, & 50 | thisyc,ey(3),Pwc_KHb,Pwc_KHc,Pwc_KHf,zb,zc,zf,m,dz 51 | DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) ::fitz,fitKH, & 52 | Pwc_KH,newxb,newyb,newxc,newyc,newxf,newyf,z 53 | 54 | !TSPACK Variables 55 | INTEGER :: IER,SigErr 56 | DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: dy 57 | DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: a,coefsm,v 58 | 59 | !Number of values to proliferate to 60 | INTEGER :: np,ng 61 | DOUBLE PRECISION :: ttime(10),dTz 62 | 63 | ! sub = 4 64 | np =int(dble(s_w(ng))*sub) 65 | !ALLOCATE VARIABLES 66 | ALLOCATE(Pwc_KH(s_w(ng))) 67 | ALLOCATE(z(s_w(ng))) 68 | ALLOCATE(dy(np)) 69 | ALLOCATE(a(np,4)) 70 | ALLOCATE(v(np,7)) 71 | ALLOCATE(coefsm(4,np)) 72 | ALLOCATE(fitz(np)) 73 | ALLOCATE(fitKH(np)) 74 | 75 | ! ********************************************************* 76 | ! * Find kh in water column profile * 77 | ! ********************************************************* 78 | 79 | ! background = 1.0D-6 80 | ! dy=.0001 81 | ! smth=6.0E-1 82 | v=0.0 83 | a=0.0 84 | coefsm=0.0 85 | fitz=0.0 86 | fitKH=0.0 87 | tdepth = DBLE(-1.0)* getInterp2D("depth",ng,Xpar,Ypar,t_c) 88 | zetab = getInterp2D("zeta",ng,Xpar,Ypar,t_b) 89 | zetac = getInterp2D("zeta",ng,Xpar,Ypar,t_c) 90 | zetaf = getInterp2D("zeta",ng,Xpar,Ypar,t_f) 91 | !i. find KH in water column profile at particle locationv(i) 92 | 93 | ey(1) = zetab 94 | ey(2) = zetac 95 | ey(3) = zetaf 96 | zeta = polintd(ex,ey,3,ix(2)) 97 | !write(*,"(F10.4,F10.4,F10.4,F10.4)") zetab,zetac,zetaf,zeta 98 | 99 | 100 | do i=1,s_w(ng) 101 | zb=getWlevel(zetab,tdepth,ng,i) 102 | zc=getWlevel(zetac,tdepth,ng,i) 103 | zf=getWlevel(zetaf,tdepth,ng,i) 104 | 105 | ey(1) = zb 106 | ey(2) = zc 107 | ey(3) = zf 108 | z(i) = polintd(ex,ey,3,ix(2)) 109 | ! Pwc_KHb(i) = getInterp3d("AKs",ng,Xpar,Ypar,zb(i),t_b,2,zetab,tdepth) 110 | ! Pwc_KHc(i) = getInterp3d("AKs",ng,Xpar,Ypar,zc(i),t_c,2,zetac,tdepth) 111 | ! Pwc_KHf(i) = getInterp3d("AKs",ng,Xpar,Ypar,zf(i),t_f,2,zetaf,tdepth) 112 | call getInterpAKs(ng,Xpar,Ypar,t_b,i,Pwc_KHb) 113 | call getInterpAKs(ng,Xpar,Ypar,t_c,i,Pwc_KHc) 114 | call getInterpAKs(ng,Xpar,Ypar,t_f,i,Pwc_KHf) 115 | 116 | ey(1) = Pwc_KHb 117 | ey(2) = Pwc_KHc 118 | ey(3) = Pwc_KHf 119 | Pwc_KH(i) = polintd(ex,ey,3,ix(2)) 120 | 121 | 122 | !WRITE(*,*) i,z(i),ZPar 123 | 124 | enddo 125 | 126 | dz=(z(s_w(ng))-z(1))/dble(np-1) 127 | fitz(1)=z(1) 128 | fitz(np)=z(s_w(ng)) 129 | fitKH(1)=Pwc_KH(1) 130 | fitKH(np)=Pwc_KH(s_w(ng)) 131 | do i=2,np-1 132 | fitz(i)=fitz(i-1)+dz 133 | 134 | call linint(z,Pwc_KH,s_w(ng),fitz(i),fitKH(i),m) 135 | dy(i)=serr 136 | end do 137 | 138 | 139 | 140 | ! do i = 1, s_w(ng) 141 | 142 | 143 | ! write ( *, '(2e15.7)' ) z(i),Pwc_KH(i) 144 | ! end do 145 | ! write(*,*) '---------------' 146 | ! do i = 1,np 147 | 148 | 149 | ! write ( *, '(2e15.7)' ) fitz(i),fitKH(i) 150 | ! end do 151 | 152 | 153 | ! do i=1,s_w(ng) 154 | ! if (ZPar.LT.z(i)) then 155 | ! itop=i+1 156 | ! ibot=i-2 157 | ! exit 158 | ! endif 159 | 160 | ! enddo 161 | ! if (ibot.eq.0) then 162 | ! ibot=ibot+1 163 | ! itop=itop+1 164 | ! endif 165 | ! if (itop.eq.s_w(ng)+1) then 166 | ! ibot=ibot-1 167 | ! itop=itop-1 168 | ! endif 169 | 170 | ! write(*,*) '---------------' 171 | ! do i=1,4 172 | ! zfit(i)=z(ibot+i-1) 173 | ! KHfit(i)=Pwc_KH(ibot+i-1) 174 | ! enddo 175 | 176 | ! ! dy=n 177 | 178 | ! write(*,*) j 179 | ! ! write(*,*) np 180 | ! write(*,*) v 181 | 182 | ast=smooth ( fitz,fitKH, dy,np,smth, v, a ) 183 | 184 | 185 | ! write(*,*) j 186 | coefsm=0.0 187 | do i = 1, np 188 | coefsm(1:4,i) = a(i,1:4) 189 | end do 190 | 191 | ! do i = 1, np 192 | ! do j = 1, 4 193 | 194 | ! a(i,j) = ppvalu ( fitz, coefsm, np-1, 4, fitz(i), j-1 ) 195 | ! end do 196 | ! ! write ( *, '(6e15.7)' ) fitz(i),a(i,1:4) 197 | ! end do 198 | 199 | ! ! ifitx(1)=z(1) 200 | ! do i=2,p2 201 | ! ifitx(i)=ifitx(i-1)+0.3 202 | ! end do 203 | 204 | ! write(*,*) '---------------' 205 | ! do i=1,p2 206 | ! do j = 1, 4 207 | ! KHfit(j)= ppvalu ( z, coefsm, s_w(ng)-1, 4, ifitx(i), j-1 ) 208 | 209 | ! end do 210 | 211 | ! write ( *, '(5e15.7)' ) ifitx(i),KHfit 212 | ! end do 213 | 214 | ! 215 | ! enddo 216 | 217 | ! ! ********************************************************* 218 | ! ! * Create Extra Points for Moving Average * 219 | ! ! ********************************************************* 220 | 221 | 222 | 223 | 224 | ! !vii. fit a tension spline to water column profile of KH using TSPACK 225 | ! !SigErr=0 226 | 227 | 228 | ! !viii. Initialize. Set deltat, number of iterations, initial z-coordinate 229 | ! deltat=1.0 ! dt= 1 sec 230 | 231 | loop= idt/int(deltat) ! number of iterations of RDM loop 232 | ParZc = Zpar !set initial particle depth 233 | !loop=1 234 | 235 | ! ********************************************************* 236 | ! * Random Displacement Model Loop * 237 | ! ********************************************************* 238 | 239 | !ix. Begin iterations 240 | do i=1,loop 241 | ! a. Determine the second term in the equation: K'(z)deltat 242 | ! 1. Find Kprime & solve for second term in RDM equation 243 | ! (K'(z)deltat = KprimeZ) 244 | Kprimec=0.0 245 | KprimeZc=0.0 246 | 247 | if (ParZc.LE.tdepth .OR. ParZc.GE.zeta) then 248 | Kprimec=0.0 249 | else 250 | ! CALL linint(fitx,ifity,p2,ParZc,thisyc,Kprimec) 251 | 252 | Kprimec = ppvalu ( fitz, coefsm, np-1, 4, ParZc, 1 ) 253 | 254 | endif 255 | 256 | 257 | KprimeZc=Kprimec*deltat 258 | 259 | ! b. Determine the 3rd term in the RDM equation: 260 | ! R{ 2/r K[z+0.5K'(z)dt]dt}**0.5 261 | ! i. Find K at location of [z+0.5K'(z)dt] = Z3rd 262 | ! 1. calculate Z3rd and make sure within boudaries 263 | Z3rdc = ParZc + DBLE(0.5)*KprimeZc 264 | 265 | ! 2. Find KH at the location Z3rd 266 | KH3rdc=0.0 267 | if (Z3rdc.LT.tdepth .OR. Z3rdc.GT.zeta) then 268 | KH3rdc=AKSback 269 | else 270 | !! CALL linint(ifitx,ifity,p2,Z3rdc,KH3rdc,slopem) 271 | KH3rdc = ppvalu ( fitz, coefsm, np-1, 4, Z3rdc, 0 ) 272 | if (KH3rdc.LT.AKSback) KH3rdc=AKSback 273 | endif 274 | 275 | ! c. Solve the entire equation 276 | DEV=norm() ! the random deviate 277 | r=1. ! the standard deviation of the random deviate 278 | 279 | 280 | !write(*,"(F10.4,F10.4,F10.4)") KprimeZc,zeta 281 | dTz=KprimeZc + DEV* (DBLE(2.0)/r * KH3rdc*deltat)**0.5 282 | newZc = ParZc + dTz 283 | !x. update particle z-coordinate 284 | ParZc = newZc 285 | 286 | 287 | if (ParZc.LE.tdepth) then 288 | ParZc = tdepth + ABS(ParZc-tdepth) 289 | endif 290 | if (ParZc.GE.zeta) then 291 | ParZc = zeta - ABS(ParZc-zeta) 292 | endif 293 | enddo !End RDM iterations 294 | 295 | ! ********************************************************* 296 | ! * Calculate displacement due to vertical turb * 297 | ! ********************************************************* 298 | 299 | ! call CPU_TIME(ttime(7)) 300 | ! write(*,*)'----' 301 | ! write(*,*) ttime(2)-ttime(1) 302 | ! write(*,*) ttime(3)-ttime(2) 303 | ! write(*,*) ttime(4)-ttime(3) 304 | ! write(*,*) ttime(5)-ttime(4) 305 | ! write(*,*) ttime(6)-ttime(5) 306 | ! write(*,*) ttime(7)-ttime(6) 307 | ! write(*,*) ttime(7)-ttime(10) 308 | !xi. find vertical displacement of particle due to turbulent diffusion 309 | TurbV = ParZc-Zpar 310 | !TurbV = 0.0 311 | 312 | 313 | ! **************** End Vertical Turbulence (RDM) ************************* 314 | ! ************************************************************************ 315 | 316 | !DEALLOCATE VARIABLES 317 | 318 | 319 | DEALLOCATE(fitz) 320 | DEALLOCATE(fitKH) 321 | DEALLOCATE(Pwc_KH) 322 | DEALLOCATE(z) 323 | DEALLOCATE(dy) 324 | DEALLOCATE(a) 325 | DEALLOCATE(coefsm) 326 | 327 | 328 | 329 | END SUBROUTINE VTurb 330 | 331 | END MODULE VTURB_MOD -------------------------------------------------------------------------------- /advection_module.f90: -------------------------------------------------------------------------------- 1 | MODULE ADVECTION_MOD 2 | 3 | 4 | ! Particle Advection module separated from main particel update progema. 5 | ! 6 | ! Created by: Elias Hunter 7 | ! Modified by: Elias Hunter 8 | ! Created on: 8/6/2019 9 | ! Last Modified on: 8/6/2019 10 | ! ROMSPath Version: 1.0.1 11 | 12 | IMPLICIT NONE 13 | PUBLIC 14 | 15 | CONTAINS 16 | 17 | 18 | ! ************************************************************************* 19 | 20 | SUBROUTINE RKAdvect(Xpar,Ypar,Zpar,ex,ix,pm,pn,ng,ets,AdvectX,AdvectY,AdvectZ) 21 | USE PARAM_MOD, ONLY: idt 22 | IMPLICIT NONE 23 | 24 | DOUBLE PRECISION, INTENT(IN) :: Xpar,Ypar,ex(3),ix(3),pm,pn 25 | INTEGER, INTENT(IN) :: ets 26 | DOUBLE PRECISION, INTENT(OUT) :: AdvectX,AdvectY,AdvectZ 27 | 28 | DOUBLE PRECISION :: kn1_u,kn1_v,kn1_w,kn2_u,kn2_v,kn2_w,kn3_u,kn3_v,kn3_w,kn4_u,kn4_v,kn4_w, & 29 | UAD,VAD,WAD,x1,x2,x3,y1,y2,y3,z1,z2,z3,P_U,P_V,P_W 30 | 31 | INTEGER :: i,j,k,jlo,loop,itop,ibot 32 | DOUBLE PRECISION :: P_depth,P_zeta,Zpar 33 | 34 | 35 | 36 | INTEGER :: ng 37 | 38 | 39 | 40 | 41 | ! ********************************************************* 42 | ! * Runga Kutta * 43 | ! ********************************************************* 44 | 45 | CALL find_currents(Xpar,Ypar,Zpar,ex,ix,ng,ets,Uad,Vad,Wad,P_depth,P_zeta) 46 | 47 | 48 | ! !Store advection currents at original coordinates 49 | kn1_u = Uad*pm 50 | kn1_v = Vad*pn 51 | kn1_w = Wad 52 | 53 | ! !Estimate new coordinates for next RK position 54 | x1 = Xpar + Uad*pm*DBLE(idt)/DBLE(2) 55 | y1 = Ypar + Vad*pn*DBLE(idt)/DBLE(2) 56 | z1 = Zpar + Wad*DBLE(idt)/DBLE(2) 57 | ! if(z1 .GT. minpartdepth) z1 = minpartdepth - DBLE(0.000001) 58 | ! if(z1 .LT. maxpartdepth) z1 = maxpartdepth + DBLE(0.000001) 59 | ! OPEN(1,FILE='testdata2') 60 | ! write(1,"(F10.4,F10.4)") P_depth,P_zeta 61 | ! write(1,"(E14.5,E14.5,E14.5,E14.5)") Xpar,Ypar,Zpar 62 | ! write(1,"(E14.5,E14.5,E14.5,E14.5)") x1,y1,z1 63 | ! CLOSE(1) 64 | ! !Find advection currents at estimated next RK position 65 | CALL find_currents(x1,y1,z1,ex,ix,ng,ets,Uad,Vad,Wad,P_depth,P_zeta) 66 | ! CALL find_currents(x1,y1,z1,Pwc_zb,Pwc_zc,Pwc_zf,Pwc_wzb,Pwc_wzc, & 67 | ! Pwc_wzf,P_zb,P_zc,P_zf,ex,ix,p,2,Uad,Vad,Wad) 68 | 69 | ! !Store advection currents at 2nd RK position 70 | kn2_u = Uad*pm 71 | kn2_v = Vad*pn 72 | kn2_w = Wad 73 | 74 | ! !Estimate new coordinates for next RK position 75 | x2 = Xpar + Uad*pm*DBLE(idt)/DBLE(2) 76 | y2 = Ypar + Vad*pn*DBLE(idt)/DBLE(2) 77 | z2 = Zpar + Wad*DBLE(idt)/DBLE(2) 78 | ! if(z2 .GT. minpartdepth) z2 = minpartdepth - DBLE(0.000001) 79 | ! if(z2 .LT. maxpartdepth) z2 = maxpartdepth + DBLE(0.000001) 80 | 81 | ! !Find advection currents at estimated next RK position 82 | 83 | 84 | 85 | CALL find_currents(x2,y2,z2,ex,ix,ng,ets,Uad,Vad,Wad,P_depth,P_zeta) 86 | ! CALL find_currents(x2,y2,z2,Pwc_zb,Pwc_zc,Pwc_zf,Pwc_wzb,Pwc_wzc, & 87 | ! Pwc_wzf,P_zb,P_zc,P_zf,ex,ix,p,2,Uad,Vad,Wad) 88 | 89 | ! !Store advection currents at 3rd RK position 90 | kn3_u = Uad*pm 91 | kn3_v = Vad*pn 92 | kn3_w = Wad 93 | 94 | ! !Calculate the coordinates at the final position 95 | 96 | x3 = Xpar + Uad*pm*DBLE(idt)/DBLE(2) 97 | y3 = Ypar + Vad*pn*DBLE(idt)/DBLE(2) 98 | z3 = Zpar + Wad*DBLE(idt)/DBLE(2) 99 | ! if(z3 .GT. minpartdepth) z3 = minpartdepth - DBLE(0.000001) 100 | ! if(z3 .LT. maxpartdepth) z3 = maxpartdepth + DBLE(0.000001) 101 | 102 | ! !Find advection currents at the final position 103 | CALL find_currents(x3,y3,z3,ex,ix,ng,ets,Uad,Vad,Wad,P_depth,P_zeta) 104 | ! CALL find_currents(x3,y3,z3,Pwc_zb,Pwc_zc,Pwc_zf,Pwc_wzb,Pwc_wzc, & 105 | ! Pwc_wzf,P_zb,P_zc,P_zf,ex,ix,p,3,Uad,Vad,Wad) 106 | 107 | ! !Store advection currents at final position 108 | kn4_u = Uad*pm 109 | kn4_v = Vad*pn 110 | kn4_w = Wad 111 | 112 | ! !Use the RK formula to get the final Advection values 113 | P_U = (kn1_u + DBLE(2.0)*kn2_u + DBLE(2.0)*kn3_u + kn4_u)/DBLE(6.0) 114 | P_V = (kn1_v + DBLE(2.0)*kn2_v + DBLE(2.0)*kn3_v + kn4_v)/DBLE(6.0) 115 | P_W = (kn1_w + DBLE(2.0)*kn2_w + DBLE(2.0)*kn3_w + kn4_w)/DBLE(6.0) 116 | 117 | AdvectX = idt*(P_U) 118 | AdvectY = idt*(P_V) 119 | AdvectZ = idt*P_W 120 | 121 | 122 | 123 | 124 | 125 | END SUBROUTINE RKAdvect 126 | 127 | 128 | 129 | SUBROUTINE find_currents(Xpar,Ypar,Zpar,ex,ix,ng,ets,Uad,Vad,Wad,tdepth,zeta) 130 | !This Subroutine calculates advection currents at the particle's 131 | ! location in space and time 132 | USE PARAM_MOD, ONLY: t_b,t_c,t_f,s_rho,s_w,zob 133 | USE GRID_MOD, ONLY: GRIDS 134 | USE INT_MOD, ONLY: getInterp2D,getInterp3D,polintd 135 | IMPLICIT NONE 136 | 137 | DOUBLE PRECISION, INTENT(IN) :: Xpar,Ypar,ex(3),ix(3) 138 | DOUBLE PRECISION, INTENT(INOUT) ::Zpar 139 | DOUBLE PRECISION, INTENT(OUT) :: Uad,Vad,Wad,tdepth,zeta 140 | 141 | INTEGER, INTENT(IN) :: ets 142 | 143 | INTEGER :: i,ii,iii,ng,version 144 | DOUBLE PRECISION :: P_Ub,P_Uc,P_Uf,P_Vb,P_Vc,P_Vf,P_Wb,P_Wc,P_Wf,ey(3), & 145 | Pwc_ub,Pwc_uc,Pwc_uf,Pwc_vb,Pwc_vc,Pwc_vf,Pwc_wb,Pwc_wc,Pwc_wf 146 | 147 | DOUBLE PRECISION :: pm,pn,zetab,zetac,zetaf,& 148 | zb,zc,zf 149 | 150 | tdepth = DBLE(-1.0)* getInterp2D("depth",ng,Xpar,Ypar,t_c) 151 | zetab = getInterp2D("zeta",ng,Xpar,Ypar,t_b) 152 | zetac = getInterp2D("zeta",ng,Xpar,Ypar,t_c) 153 | zetaf = getInterp2D("zeta",ng,Xpar,Ypar,t_f) 154 | 155 | 156 | ! write(*,"(F10.4,F10.4,F10.4)") zetab,zetac,zetaf 157 | !******************************* 158 | !******************************* 159 | !*****KLUDGE WARNIN****************** 160 | !******************************* 161 | version=2 162 | 163 | !******************************* 164 | !******************************* 165 | !******************************* 166 | !******************************* 167 | ! ! !Check if particle location above or below boundary, If so, place 168 | ! ! ! just within boundary (1 mm) 169 | 170 | 171 | if (Zpar.LT.tdepth) then 172 | Zpar = tdepth + DBLE(0.001) 173 | !IF(TrackCollisions) hitBottom(n) = hitBottom(n) + 1 174 | endif 175 | 176 | 177 | 178 | ey(1) = zetab 179 | ey(2) = zetac 180 | ey(3) = zetaf 181 | zeta = polintd(ex,ey,3,ix(2)) 182 | 183 | if (Zpar.GT.zeta) Zpar = zeta - DBLE(0.001) 184 | 185 | 186 | 187 | 188 | ! ! ********************************************************* 189 | ! ! * * 190 | ! ! * Create Matrix of Z-coordinates * 191 | ! ! * * 192 | ! ! ********************************************************* 193 | 194 | ! !Create matrix of z-coordinates at particle and at each node for 195 | ! ! back, center, forward times 196 | !write(*,*) '------------------' 197 | 198 | ! ********************************************************* 199 | ! * * 200 | ! * Calculate U,V,W in Water Column Profile * 201 | ! * * 202 | ! ********************************************************* 203 | 204 | 205 | !i. Determine if particle is deep enough that velocities are affected by 206 | ! the bottom. 207 | ! If so, apply log layer between deepest current velocity predicitons 208 | ! (deepest rho s-level for u,v and deepest w s-level for w) and bottom. 209 | ! ! OR, if below z0, set advection velocities to 0.0 210 | ! if ((Zpar .LT. Pwc_wzb(1)+z0) .OR. & 211 | ! (Zpar .LT. Pwc_wzc(1)+z0) .OR. & 212 | ! (Zpar .LT. Pwc_wzf(1)+z0) ) then 213 | 214 | ! Uad = 0.0 215 | ! Vad = 0.0 216 | ! Wad = 0.0 217 | 218 | ! elseif ((Zpar .LT. Pwc_zb(1)) .OR. & 219 | ! (Zpar .LT. Pwc_zc(1)) .OR. & 220 | ! (Zpar .LT. Pwc_zf(1)) ) then 221 | ! write(*,*) '----------------' 222 | Pwc_Uc = getInterp3d("u",ng,Xpar,Ypar,Zpar,t_c,1,zeta,tdepth) 223 | Pwc_Uf = getInterp3d("u",ng,Xpar,Ypar,Zpar,t_f,1,zeta,tdepth) 224 | Pwc_Ub = getInterp3d("u",ng,Xpar,Ypar,Zpar,t_b,1,zeta,tdepth) 225 | 226 | Pwc_Vb = getInterp3d("v",ng,Xpar,Ypar,Zpar,t_b,1,zeta,tdepth) 227 | Pwc_Vc = getInterp3d("v",ng,Xpar,Ypar,Zpar,t_c,1,zeta,tdepth) 228 | Pwc_Vf = getInterp3d("v",ng,Xpar,Ypar,Zpar,t_f,1,zeta,tdepth) 229 | Pwc_Wb = getInterp3d("w",ng,Xpar,Ypar,Zpar,t_b,2,zeta,tdepth) 230 | Pwc_Wc = getInterp3d("w",ng,Xpar,Ypar,Zpar,t_c,2,zeta,tdepth) 231 | Pwc_Wf = getInterp3d("w",ng,Xpar,Ypar,Zpar,t_f,2,zeta,tdepth) 232 | 233 | ! write(*,*) zeta,tdepth 234 | ! ! write(*,*) Xpar,Ypar,Zpar 235 | ! write(*,*)Pwc_Ub,Pwc_Uc,Pwc_Uf 236 | 237 | ! u(z) = [ u(z1) / (log(z1/zo) ] * (log (z/zo) 238 | !where: 239 | ! u is current velocity 240 | ! z1 is height of first sigma level above bottom 241 | ! z0 is roughness height of model 242 | ! z is height of desired velocity 243 | ! 244 | ! Note that Pwc_wzb(1) = P_depth = Depth at particle location 245 | 246 | ! P_Ub=Pwc_Ub*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_zb(1) -Pwc_wzb(1))/z0) 247 | ! P_Uc=Pwc_Uc*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_zc(1) -Pwc_wzb(1))/z0) 248 | ! P_Uf=Pwc_Uf*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_zf(1) -Pwc_wzb(1))/z0) 249 | ! P_Vb=Pwc_Vb*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_zb(1) -Pwc_wzb(1))/z0) 250 | ! P_Vc=Pwc_Vc*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_zc(1) -Pwc_wzb(1))/z0) 251 | ! P_Vf=Pwc_Vf*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_zf(1) -Pwc_wzb(1))/z0) 252 | ! P_Wb=Pwc_Wb*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_wzb(2)-Pwc_wzb(1))/z0) 253 | ! P_Wc=Pwc_Wc*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_wzc(2)-Pwc_wzb(1))/z0) 254 | ! P_Wf=Pwc_Wf*log10((Zpar-Pwc_wzb(1))/z0)/log10((Pwc_wzf(2)-Pwc_wzb(1))/z0) 255 | 256 | 257 | P_Ub=Pwc_Ub 258 | P_Uc=Pwc_Uc 259 | P_Uf=Pwc_Uf 260 | P_Vb=Pwc_Vb 261 | P_Vc=Pwc_Vc 262 | P_Vf=Pwc_Vf 263 | P_Wb=Pwc_Wb 264 | P_Wc=Pwc_Wc 265 | P_Wf=Pwc_Wf 266 | 267 | 268 | ! ********************************************************* 269 | ! * Find Internal b,c,f and Advection Values * 270 | ! ********************************************************* 271 | ! 272 | ! ii. fit polynomial to hydrodynamic model output and find internal 273 | ! b,c,f values 274 | 275 | !a. U velocity 276 | ! 1. Prepare external time step values 277 | if (ets .EQ. 1) then 278 | ey=0.0 279 | ey(1) = P_Ub 280 | ey(2) = P_Ub 281 | ey(3) = P_Uc 282 | else 283 | ey=0.0 284 | ey(1) = P_Ub 285 | ey(2) = P_Uc 286 | ey(3) = P_Uf 287 | endif 288 | 289 | ! 2. Get Advection value 290 | if(version .EQ. 1) then 291 | Uad = polintd(ex,ey,3,ix(1)) 292 | elseif (version .EQ. 2) then 293 | Uad = polintd(ex,ey,3,ix(2)) 294 | else 295 | Uad = polintd(ex,ey,3,ix(3)) 296 | endif 297 | 298 | !b. V velocity 299 | ! 1. Prepare external time step values 300 | if (ets .EQ. 1) then 301 | ey=0.0 302 | ey(1) = P_Vb 303 | ey(2) = P_Vb 304 | ey(3) = P_Vc 305 | else 306 | ey=0.0 307 | ey(1) = P_Vb 308 | ey(2) = P_Vc 309 | ey(3) = P_Vf 310 | endif 311 | 312 | ! 2. Get Advection value 313 | if(version .EQ. 1) then 314 | Vad = polintd(ex,ey,3,ix(1)) 315 | elseif (version .EQ. 2) then 316 | Vad = polintd(ex,ey,3,ix(2)) 317 | else 318 | Vad = polintd(ex,ey,3,ix(3)) 319 | endif 320 | 321 | 322 | !c. W velocity 323 | ! 1. Prepare external time step values 324 | if (ets .EQ. 1) then 325 | ey=0.0 326 | ey(1) = P_Wb 327 | ey(2) = P_Wb 328 | ey(3) = P_Wc 329 | else 330 | ey=0.0 331 | ey(1) = P_Wb 332 | ey(2) = P_Wc 333 | ey(3) = P_Wf 334 | endif 335 | 336 | ! 2. Get Advection value 337 | if(version .EQ. 1) then 338 | Wad = polintd(ex,ey,3,ix(1)) 339 | elseif (version .EQ. 2) then 340 | Wad = polintd(ex,ey,3,ix(2)) 341 | else 342 | Wad = polintd(ex,ey,3,ix(3)) 343 | endif 344 | 345 | 346 | 347 | 348 | 349 | RETURN 350 | END SUBROUTINE find_currents 351 | 352 | 353 | END MODULE ADVECTION_MOD -------------------------------------------------------------------------------- /random_module.f90: -------------------------------------------------------------------------------- 1 | MODULE RANDOM_MOD 2 | IMPLICIT NONE 3 | PUBLIC 4 | SAVE 5 | 6 | ! ROMSPath Version: 1.0.1 7 | ! The following Mersenne Twister program, mt19937ar.f, is used to generate 8 | ! random numbers between 0 and 1 from a uniform distribution. The Mersenne 9 | ! Twister is a fast random number generator with a period of 2^19937-1. 10 | ! It was downloaded from the following website: 11 | ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/VERSIONS/FORTRAN/mt19937ar.f 12 | ! See the Mersenne Twister Home Page for more information: 13 | ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html 14 | ! 15 | ! Zachary Schlag converted the program to F90 for use in ROMSPath (8/29/08). 16 | 17 | ! ************* Mersenne Twister **************** 18 | ! 19 | ! A C-program for MT19937, with initialization improved 2002/1/26. 20 | ! Coded by Takuji Nishimura and Makoto Matsumoto. 21 | ! 22 | ! Before using, initialize the state by using init_genrand(seed) 23 | ! or init_by_array(init_key, key_length). 24 | ! 25 | ! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, 26 | ! All rights reserved. 27 | ! Copyright (C) 2005, Mutsuo Saito, 28 | ! All rights reserved. 29 | ! 30 | ! Redistribution and use in source and binary forms, with or without 31 | ! modification, are permitted provided that the following conditions 32 | ! are met: 33 | ! 34 | ! 1. Redistributions of source code must retain the above copyright 35 | ! notice, this list of conditions and the following disclaimer. 36 | ! 37 | ! 2. Redistributions in binary form must reproduce the above copyright 38 | ! notice, this list of conditions and the following disclaimer in the 39 | ! documentation and/or other materials provided with the distribution. 40 | ! 41 | ! 3. The names of its contributors may not be used to ENDorse or promote 42 | ! products derived from this software without specific prior written 43 | ! permission. 44 | ! 45 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 46 | ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 47 | ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 48 | ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 49 | ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 50 | ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 51 | ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 52 | ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 53 | ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 54 | ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 55 | ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 56 | ! 57 | ! 58 | ! Any feedback is very welcome. 59 | ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html 60 | ! email: m-mat @ math.sci.hiroshima-u.ac.jp (remove space) 61 | ! 62 | !----------------------------------------------------------------------- 63 | ! FORTRAN77 translation by Tsuyoshi TADA. (2005/12/19) 64 | ! 65 | ! FORTRAN90 translation by Zachary Schlag (2008/08/29) 66 | ! 67 | ! ---------- initialize routines ---------- 68 | ! SUBROUTINE init_genrand(seed): initialize with a seed 69 | ! SUBROUTINE init_by_array(init_key,key_length): initialize by an array 70 | ! 71 | ! ---------- generate FUNCTIONs ---------- 72 | ! INTEGER FUNCTION genrand_int32(): signed 32-bit INTEGER 73 | ! INTEGER FUNCTION genrand_int31(): unsigned 31-bit INTEGER 74 | ! DOUBLE PRECISION FUNCTION genrand_real1(): [0,1] with 32-bit resolution 75 | ! DOUBLE PRECISION FUNCTION genrand_real2(): [0,1) with 32-bit resolution 76 | ! DOUBLE PRECISION FUNCTION genrand_real3(): (0,1) with 32-bit resolution 77 | ! DOUBLE PRECISION FUNCTION genrand_res53(): (0,1) with 53-bit resolution 78 | ! 79 | ! This program uses the following non-standard intrinsics. 80 | ! ishft(i,n): If n>0, shifts bits in i by n positions to left. 81 | ! If n<0, shifts bits in i by n positions to right. 82 | ! iand (i,j): Performs logical AND on corresponding bits of i and j. 83 | ! ior (i,j): Performs inclusive OR on corresponding bits of i and j. 84 | ! ieor (i,j): Performs exclusive OR on corresponding bits of i and j. 85 | ! 86 | 87 | INTEGER, PRIVATE, PARAMETER :: N = 624 88 | INTEGER, PRIVATE, PARAMETER :: M = 397 89 | INTEGER, PRIVATE, PARAMETER :: DONE = 123456789 90 | 91 | INTEGER, PRIVATE :: ALLBIT_MASK 92 | INTEGER, PRIVATE :: TOPBIT_MASK 93 | INTEGER, PRIVATE :: UPPER_MASK 94 | INTEGER, PRIVATE :: LOWER_MASK 95 | INTEGER, PRIVATE :: MATRIX_A 96 | INTEGER, PRIVATE :: T1_MASK 97 | INTEGER, PRIVATE :: T2_MASK 98 | INTEGER, PRIVATE :: mag01(0:1) 99 | INTEGER, PRIVATE :: mt(0:N-1) 100 | INTEGER, PRIVATE :: mti 101 | INTEGER, PRIVATE :: initialized 102 | 103 | CONTAINS 104 | 105 | 106 | !----------------------------------------------------------------------- 107 | ! initialize mt(0:N-1) with a seed 108 | !----------------------------------------------------------------------- 109 | SUBROUTINE init_genrand(s) 110 | INTEGER, INTENT(IN) :: s 111 | 112 | CALL mt_initln 113 | mt(0)=iand(s,ALLBIT_MASK) 114 | do mti=1,N-1 115 | mt(mti)=1812433253*ieor(mt(mti-1),ishft(mt(mti-1),-30))+mti 116 | mt(mti)=iand(mt(mti),ALLBIT_MASK) 117 | enddo 118 | initialized=DONE 119 | 120 | END SUBROUTINE init_genrand 121 | 122 | 123 | !----------------------------------------------------------------------- 124 | ! initialize by an array with array-length 125 | ! init_key is the array for initializing keys 126 | ! key_length is its length 127 | !----------------------------------------------------------------------- 128 | SUBROUTINE init_by_array(init_key,key_length) 129 | INTEGER, INTENT(IN) :: init_key(0:*) 130 | INTEGER, INTENT(IN) :: key_length 131 | 132 | INTEGER :: i,j,k 133 | 134 | CALL init_genrand(19650218) 135 | i=1 136 | j=0 137 | do k=max(N,key_length),1,-1 138 | mt(i)=ieor(mt(i),ieor(mt(i-1),ishft(mt(i-1),-30))*1664525)+init_key(j)+j 139 | mt(i)=iand(mt(i),ALLBIT_MASK) 140 | i=i+1 141 | j=j+1 142 | if(i.ge.N)then 143 | mt(0)=mt(N-1) 144 | i=1 145 | endif 146 | if(j.ge.key_length)then 147 | j=0 148 | endif 149 | enddo 150 | do k=N-1,1,-1 151 | mt(i)=ieor(mt(i),ieor(mt(i-1),ishft(mt(i-1),-30))*1566083941)-i 152 | mt(i)=iand(mt(i),ALLBIT_MASK) 153 | i=i+1 154 | if(i.ge.N)then 155 | mt(0)=mt(N-1) 156 | i=1 157 | endif 158 | enddo 159 | mt(0)=TOPBIT_MASK 160 | 161 | END SUBROUTINE init_by_array 162 | 163 | 164 | !----------------------------------------------------------------------- 165 | ! generates a random number on [0,0xffffffff]-interval 166 | !----------------------------------------------------------------------- 167 | INTEGER FUNCTION genrand_int32() 168 | INTEGER :: y,kk 169 | 170 | if(initialized.ne.DONE)then 171 | CALL init_genrand(21641) 172 | endif 173 | 174 | if(mti.ge.N)then 175 | do kk=0,N-M-1 176 | y=ior(iand(mt(kk),UPPER_MASK),iand(mt(kk+1),LOWER_MASK)) 177 | mt(kk)=ieor(ieor(mt(kk+M),ishft(y,-1)),mag01(iand(y,1))) 178 | enddo 179 | do kk=N-M,N-1-1 180 | y=ior(iand(mt(kk),UPPER_MASK),iand(mt(kk+1),LOWER_MASK)) 181 | mt(kk)=ieor(ieor(mt(kk+(M-N)),ishft(y,-1)),mag01(iand(y,1))) 182 | enddo 183 | y=ior(iand(mt(N-1),UPPER_MASK),iand(mt(0),LOWER_MASK)) 184 | mt(kk)=ieor(ieor(mt(M-1),ishft(y,-1)),mag01(iand(y,1))) 185 | mti=0 186 | endif 187 | 188 | y=mt(mti) 189 | mti=mti+1 190 | 191 | y=ieor(y,ishft(y,-11)) 192 | y=ieor(y,iand(ishft(y,7),T1_MASK)) 193 | y=ieor(y,iand(ishft(y,15),T2_MASK)) 194 | y=ieor(y,ishft(y,-18)) 195 | 196 | genrand_int32=y 197 | 198 | END FUNCTION genrand_int32 199 | 200 | 201 | !----------------------------------------------------------------------- 202 | ! generates a random number on [0,0x7fffffff]-interval 203 | !----------------------------------------------------------------------- 204 | INTEGER FUNCTION genrand_int31() 205 | 206 | genrand_int31=int(ishft(genrand_int32(),-1)) 207 | 208 | END FUNCTION genrand_int31 209 | 210 | 211 | !----------------------------------------------------------------------- 212 | ! generates a random number on [0,1]-real-interval 213 | !----------------------------------------------------------------------- 214 | DOUBLE PRECISION FUNCTION genrand_real1() 215 | DOUBLE PRECISION :: r 216 | 217 | r=dble(genrand_int32()) 218 | if(r.lt.0.d0)r=r+2.d0**32 219 | genrand_real1=r/4294967295.d0 220 | 221 | END FUNCTION genrand_real1 222 | 223 | 224 | !----------------------------------------------------------------------- 225 | ! generates a random number on [0,1)-real-interval 226 | !----------------------------------------------------------------------- 227 | DOUBLE PRECISION FUNCTION genrand_real2() 228 | DOUBLE PRECISION :: r 229 | 230 | r=dble(genrand_int32()) 231 | if(r.lt.0.d0)r=r+2.d0**32 232 | genrand_real2=r/4294967296.d0 233 | 234 | END FUNCTION genrand_real2 235 | 236 | 237 | !----------------------------------------------------------------------- 238 | ! generates a random number on (0,1)-real-interval 239 | !----------------------------------------------------------------------- 240 | DOUBLE PRECISION FUNCTION genrand_real3() 241 | DOUBLE PRECISION :: r 242 | 243 | r=dble(genrand_int32()) 244 | if(r.lt.0.d0)r=r+2.d0**32 245 | genrand_real3=(r+0.5d0)/4294967296.d0 246 | 247 | END FUNCTION genrand_real3 248 | 249 | 250 | !----------------------------------------------------------------------- 251 | ! generates a random number on [0,1) with 53-bit resolution 252 | !----------------------------------------------------------------------- 253 | DOUBLE PRECISION FUNCTION genrand_res53() 254 | DOUBLE PRECISION :: a,b 255 | 256 | a=dble(ishft(genrand_int32(),-5)) 257 | b=dble(ishft(genrand_int32(),-6)) 258 | if(a.lt.0.d0)a=a+2.d0**32 259 | if(b.lt.0.d0)b=b+2.d0**32 260 | genrand_res53=(a*67108864.d0+b)/9007199254740992.d0 261 | 262 | END FUNCTION genrand_res53 263 | 264 | 265 | !----------------------------------------------------------------------- 266 | ! initialize large number (over 32-bit constant number) 267 | !----------------------------------------------------------------------- 268 | SUBROUTINE mt_initln() 269 | 270 | TOPBIT_MASK=1073741824 271 | TOPBIT_MASK=ishft(TOPBIT_MASK,1) 272 | ALLBIT_MASK=2147483647 273 | ALLBIT_MASK=ior(ALLBIT_MASK,TOPBIT_MASK) 274 | UPPER_MASK=TOPBIT_MASK 275 | LOWER_MASK=2147483647 276 | MATRIX_A=419999967 277 | MATRIX_A=ior(MATRIX_A,TOPBIT_MASK) 278 | T1_MASK=489444992 279 | T1_MASK=ior(T1_MASK,TOPBIT_MASK) 280 | T2_MASK=1875247104 281 | T2_MASK=ior(T2_MASK,TOPBIT_MASK) 282 | mag01(0)=0 283 | mag01(1)=MATRIX_A 284 | 285 | END SUBROUTINE mt_initln 286 | 287 | SUBROUTINE init_random_seed(seed) 288 | 289 | implicit none 290 | #ifdef IFORT 291 | integer, external :: GETPID 292 | #endif 293 | 294 | INTEGER, INTENT(OUT) :: seed 295 | 296 | integer :: i, un, istat, dt(8), pid, t(2), s 297 | integer(8) :: count, tms 298 | 299 | ! First try if the OS provides a random number generator 300 | open(newunit=un, file="/dev/urandom", access="stream", & 301 | form="unformatted", action="read", status="old", iostat=istat) 302 | 303 | if (istat == 0) then 304 | write(*,*) 'USING SYSTEM RANDOM SEED' 305 | read(un) seed 306 | close(un) 307 | else 308 | 309 | write(*,*) 'USING TIME/PID SEED' 310 | ! Fallback to XOR:ing the current time and pid. The PID is 311 | ! useful in case one launches multiple instances of the same 312 | ! program in parallel. 313 | call system_clock(count) 314 | if (count /= 0) then 315 | t = transfer(count, t) 316 | else 317 | call date_and_time(values=dt) 318 | tms = (dt(1) - 1970) * 365_8 * 24 * 60 * 60 * 1000 & 319 | + dt(2) * 31_8 * 24 * 60 * 60 * 1000 & 320 | + dt(3) * 24 * 60 * 60 * 60 * 1000 & 321 | + dt(5) * 60 * 60 * 1000 & 322 | + dt(6) * 60 * 1000 + dt(7) * 1000 & 323 | + dt(8) 324 | t = transfer(tms, t) 325 | end if 326 | s = ieor(t(1), t(2)) 327 | pid = getpid() + 1099279 ! Add a prime 328 | s = ieor(s, pid) 329 | ! if (n >= 3) then 330 | ! seed(1) = t(1) + 36269 331 | ! seed(2) = t(2) + 72551 332 | ! seed(3) = pid 333 | ! if (n > 3) then 334 | ! seed(4:) = s + 37 * (/ (i, i = 0, n - 4) /) 335 | ! end if 336 | ! else 337 | seed = s 338 | ! end if 339 | end if 340 | END SUBROUTINE init_random_seed 341 | 342 | 343 | 344 | END MODULE RANDOM_MOD -------------------------------------------------------------------------------- /ROMSPath.data: -------------------------------------------------------------------------------- 1 | 2 | ! ******************************* ROMSPath Input Data File ******************************* 3 | 4 | !---- This is the file that contains input values for ROMSPath with parameters grouped --- 5 | !---- (Previously ROMSPath.inc) 6 | !*** NUMBER OF PARTICLES *** 7 | $numparticles 8 | 9 | numpar = 3000 ! Number of particles per file (total number for sim. on each node) !CHANGE 10 | ! numpar should equal the number of rows in the particle 11 | ! locations input file 12 | $end 13 | 14 | 15 | 16 | !*** TIME PARAMETERS *** 17 | $timeparam 18 | 19 | days = 0.25 ! Number of days to run the model !CHANGE 20 | iprint = 3600 ! Print interval for ROMSPath output (s); 3600 = every hour 21 | dt = 720 ! External time step (duration between hydro model predictions) (s) 22 | idt = 60 ! Internal (particle tracking) time step (s) 23 | 24 | $end 25 | 26 | 27 | 28 | !*** ROMS HYDRODYNAMIC MODULE PARAMETERS *** 29 | $hydroparam 30 | 31 | readZeta = .TRUE. ! If .TRUE. read in sea-surface height (zeta) from NetCDF file, else use constZeta 32 | constZeta = 0.0 ! Constant value for Zeta if readZeta is .FALSE. 33 | readSalt = .TRUE. ! If .TRUE. read in salinity (salt) from NetCDF file, else use constSalt 34 | constSalt = 0.0 ! Constant value for Salt if readSalt is .FALSE. 35 | readTemp = .TRUE. ! If .TRUE. read in temperature (temp) from NetCDF file, else use constTemp 36 | constTemp = 0.0 ! Constant value for Temp if readTemp is .FALSE. 37 | readU = .TRUE. ! If .TRUE. read in u-momentum component (U ) from NetCDF file, else use constU 38 | constU = 0.0 ! Constant value for U if readU is .FALSE. 39 | readV = .TRUE. ! If .TRUE. read in v-momentum component (V ) from NetCDF file, else use constV 40 | constV = 0.0 ! Constant value for V if readV is .FALSE. 41 | readW = .TRUE. ! If .TRUE. read in w-momentum component (W ) from NetCDF file, else use constW 42 | constW = 0.0 ! Constant value for W if readW is .FALSE. 43 | readAks = .TRUE. ! If .TRUE. read in salinity vertical diffusion coefficient (Aks ) from NetCDF file, else 44 | ! use constAks 45 | constAks = 0.0 ! Constant value for Aks if readAks is .FALSE. 46 | readDens = .FALSE. 47 | constDens = 0.0 48 | 49 | stokesprefix='/projects/f_hfuchs_1/stokes/snaildel_nestV04a/snaildel_stokes_' 50 | ,'/projects/f_hfuchs_1/stokes/snaildel_nestV04a/doppio_stokes_' !CHANGE 51 | turbstd_v_a_prefix='/projects/f_hfuchs_1/accelvort/snaildel_nestV04a/snaildel_turbvortaccel_' 52 | ,'/projects/f_hfuchs_1/accelvort/snaildel_nestV04a/doppio_turbvortaccel_' !CHANGE 53 | wavestd_prefix='/projects/f_hfuchs_1/accelvort/wave_snaildel_nestV04a/snaildel_waveaccel_' 54 | ,'/projects/f_hfuchs_1/accelvort/wave_snaildel_nestV04a/doppio_waveaccel_' !CHANGE 55 | 56 | Process_VA =.TRUE. ! PROCESS Vort./accel and write to netcdf file. 57 | Process_WA =.TRUE. ! PROCESS Wave Accel and write to netcdf file. 58 | $end 59 | 60 | 61 | 62 | !*** TURBULENCE MODULE PARAMETERS *** 63 | $turbparam 64 | 65 | VTurbOn = .FALSE. ! Vertical Turbulence on (.TRUE.) or off (.FALSE.) 66 | serr=0.0001 !Aks Cubic spline error Cutoff 67 | smth=0.6 !Aks Cubic spline smoothing parameter 68 | sub=4.0 !Resolution multiplier for Aks cubic spline smoothing 69 | deltat=1.0 ! vertical tubrulence parameter time step (seconds) 70 | AKSback=1.0D-8 ! Background diffusivity 71 | HTurbOn = .FALSE. ! Horizontal Turbulence on (.TRUE.) or off (.FALSE.) 72 | ConstantHTurb = 2.85714d0 20.0d0 ! Constant value of horizontal turbulence (m2/s) 73 | $end 74 | 75 | 76 | !*** Advection MODULE PARAMETERS *** 77 | $advectparam 78 | scheme= 1 ! 1 - 4th order RK,else no advection 79 | nsb=0 !0=Neutral,1- Surface trapped, 2 - Bottom trapped !CHANGE 80 | vertdist=0.25 ! (m) Used for nsb-2 or 3. Particles held at vertdist from surface or bottom. 81 | 82 | $end 83 | 84 | 85 | 86 | 87 | !*** BEHAVIOR MODULE PARAMETERS *** 88 | $behavparam 89 | 90 | Behavior = 0 ! Behavior type (specify a number) !CHANGE 91 | ! Note: The behavior types numbers are: 92 | ! 0 Passive, 1 swim , 10: Fuchs Behavior parameterization. , 11: No Behavior,output vorticity/acceleration. 93 | 94 | 95 | OpenOceanBoundary = .TRUE. ! Note: If you want to allow particles to "escape" via open ocean 96 | ! boundaries, set this to TRUE; Escape means that the particle 97 | ! will stick to the boundary and stop moving 98 | pediage = 302400 ! Age when particle reaches max swim speed and can settle (s) 99 | ! Note: for oyster larvae behavior types (4 & 5), 100 | ! pediage = age at which a particle becomes a pediveliger 101 | ! Note: pediage does not cause particles to settle if 102 | ! the Settlement module is not on 103 | swimstart = 0.0 ! Age that swimming or sinking begins (s) 1 day = 1.*24.*3600. 104 | swimslow = 0.0005 ! Swimming speed when particle begins to swim (m/s) 105 | swimfast = 0.0005 ! Maximum swimming speed (m/s) 0.005 m/s for 5 mm/s 106 | ! Note: for constant swimming speed for behavior type 1, 107 | ! set swimslow = swimfast = constant speed 108 | Sgradient = 1.0 ! Salinity gradient threshold that cues larval behavior (psu/m) 109 | ! Note: This parameter is only used if Behavior = 4 or 5. 110 | sink = -0.0003 ! Sinking velocity for behavior type 6 111 | ! Note: This parameter is only used if Behavior = 6. 112 | 113 | ! Tidal Stream Transport behavior type: 114 | Hswimspeed = 0.9 ! Horizontal swimming speed (m/s) 115 | Swimdepth = 2 ! Depth at which fish swims during flood time 116 | ! in meters above bottom (this should be a positive value 117 | ! Note: this formulation may need some work 118 | 119 | $end 120 | 121 | 122 | !*** BEHAVIOR MODULE PARAMETERS *** 123 | $fuchsparam 124 | !%%%%%%%%%%%%%%%%% VORTICITY RESPONSES 125 | vort_cr=1 !%(s^-1) critical vorticity for inducing response 126 | vort_sat=10 !%(s^-1) vorticity where response saturates 127 | 128 | b0pv=.5 !% min probability of swimming vs. vorticity 129 | b1pv=1 !% max probability of swimming vs. vorticity 130 | b0wv=0 !% (cm s^-1) max swimming velocity vs vorticity -- keep it for flexibility 131 | b1w=0 !% (cm s^-1) neutral buoyancy (no response) 132 | 133 | !%%%%%%%%%%%%%%%%% ACCELERATION RESPONSES 134 | acc_cr= 10 !%(cm s^-2) critical acceleration for inducing response 135 | acc_sat= 1000 !%(cm s^-2) acceleration where response saturates 136 | 137 | b0pa=.5 !% min probability of swimming vs. acceleration 138 | b1pa=1 !% max probability of swimming vs. acceleration 139 | b0wa=0.2 !% (cm s^-1) max swimming velocity vs acceleration 140 | 141 | va_flag=1 ! 0=Both, 1=Vorticity Only, 2=Acceleration Only 142 | 143 | $end 144 | 145 | !*** Growth MODULE PARAMETERS *** 146 | $growparam 147 | 148 | Growth=0 ! Growth type (specify a number) 149 | ! Note: The growth types numbers are: 150 | ! 0 none, 1 Use deadage, 2 Use Growth equation, 151 | mortality =.TRUE. ! TRUE if particles can die; else FALSE 152 | deadage=3888000 ! Age at which a particle stops moving (i.e., dies) (s) 153 | ! Note: deadage stops particle motion for all behavior types (0-6) 154 | initsize =250.0 ! Initial size of Larva(Egg size?) 155 | maxsize=1000.0 ! Maximum size of larva. (Stop moving after this) 156 | tempcut=2.0 ! Temperature cutoff for growth 157 | a0=-29.8 ! Growth Coefficient 0 158 | a1=3.86 ! Growth Coefficient 1 159 | a2=0.0 ! Growth Coefficient 2 160 | a3=0.0 ! Growth Coefficient 3 161 | a4=-0.070 ! Growth Coefficient 4 162 | a5=0.0 ! Growth Coefficient 5 163 | a6=0.0 ! Growth Coefficient 6 164 | a7=0.0 ! Growth Coefficient 7 165 | a8=0.0 ! Growth Coefficient 8 166 | 167 | 168 | $end 169 | 170 | !*** DVM IS CURRENTLY NOT USED AT ALL!!!!!!!!!!!!!!!!!!!!!!!!***** 171 | !*** DVM. The following are parameters for the Diurnal Vertical Migration (DVM) behavior type *** 172 | ! Note: These values were calculated for September 1 at the latitude of 37.0 (Chesapeake Bay mouth) 173 | ! Note: Variables marked with ** were calculated with light_v2BlueCrab.f (not included in ROMSPath yet) 174 | ! Note: These parameters are only used if Behavior = 3 175 | $dvmparam 176 | 177 | twistart = 4.801821 ! Time of twilight start (hr) ** 178 | twiend = 19.19956 ! Time of twilight end (hr) ** 179 | daylength = 14.39774 ! Length of day (hr) ** 180 | Em = 1814.328 ! Irradiance at solar noon (microE m^-2 s^-1) ** 181 | Kd = 1.07 ! Vertical attenuation coefficient 182 | thresh = 0.0166 ! Light threshold that cues behavior (microE m^-2 s^-1) 183 | 184 | $end 185 | 186 | !*** SETTLEMENT IS CURRENTLY NOT USED AT ALL!!!!!!!!!!!!!!!!!!!!!!!!!!!***** 187 | 188 | !*** SETTLEMENT MODULE PARAMETERS *** 189 | $settleparam 190 | 191 | settlementon = .FALSE. ! settlement module on (.TRUE.) or off (.FALSE.) 192 | ! Note: If settlement is off: set minholeid, maxholeid, minpolyid, 193 | ! maxpolyid, pedges, & hedges to 1 194 | ! to avoid both wasted variable space and errors due to arrays of size 0. 195 | ! If settlement is on and there are no holes: set minholeid, 196 | ! maxholeid, and hedges to 1 197 | holesExist = .TRUE. ! Are there holes in habitat? yes(TRUE) no(FALSE) 198 | minpolyid = 101001 ! Lowest habitat polygon id number 199 | maxpolyid = 101004 ! Highest habitat polygon id number 200 | minholeid = 100201 ! Lowest hole id number 201 | maxholeid = 100401 ! Highest hole id number 202 | pedges = 67 ! Number of habitat polygon edge points (# of rows in habitat polygon file) 203 | hedges = 32 ! Number of hole edge points (number of rows in holes file) 204 | 205 | $end 206 | 207 | 208 | 209 | 210 | $romsgrid 211 | Ngrid=2 ! Refinement grids only! 212 | refine=7 ! grid refinement, Should be Ngrid-1 long 213 | $end 214 | 215 | 216 | ! ** ROMS Predictions NetCDF Input (History) File ** 217 | !Filename = prefix + filenum + suffix 218 | !Note: the path to the file is necessary if the file is not in the same folder as the code 219 | !Note: if .nc file in separate folder in Windows, then include path in prefix. For example: 220 | ! prefix='D:\ROMS\y95hdr_' 221 | ! if .nc file in separate folder in Linux, then include path in prefix. For example: 222 | ! prefix='/share/lzhong/1995/y95hdr_' 223 | ! Need Ngrid file names for nested grids 224 | !prefix='/home/hunter/Projects/larvawave/ltrans/data/snaildel_nest/snaildel_his_' 225 | !,'/home/hunter/Projects/larvawave/ltrans/data/snaildel_nest/doppio_his_' 226 | 227 | 228 | $romsoutput 229 | suffix='.nc' !File suffice required 230 | prefix='/projects/f_hfuchs_1/data/ROMS/snaildel_nestV04a00/snaildel_his_' 231 | ,'/projects/f_hfuchs_1/data/ROMS/snaildel_nestV04a00/doppio_his_' !CHANGE 232 | 233 | 234 | time_vname='time' ! NetCDF Input Time variable name (usually ocean_time) 235 | time_dname='time' ! NetCDF Input Time dimension name (usually ocean_time) 236 | filenum = 0002 ! Number in first NetCDF input filename !!*******CHANGE*********** 237 | numdigits = 4 ! Number of digits in number portion of file name (with leading zeros)!!*******CHANGE*********** 238 | ! startfile = .FALSE. ! Is it the first file, i.e. does the file have an additional time step?!!*******CHANGE*********** 239 | multifile = .FALSE. !.TRUE. means multiple files are used with indexing. .False. means only a single file/url 240 | $end 241 | 242 | 243 | ! ** Particle Location Input File ** 244 | !Note: the path to the file is necessary if the file is not in the same folder as the code 245 | ! parfile = '/home/elhunter/ROMSPath/ROMSPathnesting/ROMSPath_INIT_TIMES.csv' !Particle locations 246 | ! parfile = '/home/elhunter/ROMSPath/ROMSPathv3/TESTINIT.csv' !Particle locations 247 | $parloc 248 | 249 | parfile = './init_nested.csv' !Particle locations !CHANGE 250 | 251 | $end 252 | 253 | 254 | ! ** Habitat Polygon Location Input Files ** 255 | !Note: the path to the file is necessary if the file is not in the same folder as the code 256 | $habpolyloc 257 | 258 | habitatfile = './input/End_polygons.csv' !Habitat polygons 259 | holefile = './input/End_holes.csv' !Holes in habitat polygons 260 | 261 | $end 262 | 263 | 264 | ! ** Output Related Variables ** 265 | $output 266 | 267 | !NOTE: Full path must already exist. Model can create files, but not directories. 268 | 269 | outpath = './' ! Location to write output files !CHANGE 270 | ! Use outpath = './' to write in same folder as the executable 271 | NCOutFile = 'SHOWNESTING_NOMIX' ! Name of the NetCDF output files (do not include .nc) 272 | 273 | outpathGiven = .TRUE. ! If TRUE files are written to the path given in outpath 274 | 275 | NCtime = 0 ! Time interval between creation of new NetCDF output files (seconds) 276 | ! Note: setting this to 0 will result in just one large output file 277 | !NetCDF Model Metadata (these will be stale unless you edit them): 278 | RunName = 'ROMSPath v.4.2 test case' 279 | ExeDir = '.' 280 | OutDir = './output' 281 | RunBy = 'ELI HUNTER' 282 | Institution = 'RUTGERS' 283 | StartedOn = 'A time in 2019' 284 | $end 285 | 286 | 287 | 288 | !*** OTHER PARAMETERS *** 289 | $other 290 | 291 | seed = 0 ! Seed value for random number generator (Mersenne Twister) 292 | ErrorFlag = 3 ! What to do if an error is encountered: 0=stop, 1=return particle to previous location, 293 | ! 2=kill particle & stop tracking that particle, 3=set particle out of bounds & 294 | ! stop tracking that particle 295 | ! Note: Options 1-3 will output information to ErrorLog.txt 296 | ! Note: This is only for particles that travel out of bounds illegally 297 | SaltTempOn = .TRUE. ! Calculate salinity and temperature at particle 298 | SaltTempMean = .TRUE. 299 | WriteBottom = .TRUE. 300 | WriteWaterDepth = .TRUE. 301 | 302 | 303 | TempOffset = 0.0 ! Temperature offset applied to growth !CHANGE 304 | ! (Temp used for growth) = (ROMS output temp) + TempOffset 305 | 306 | TrackCollisions = .FALSE. ! Write Bottom and Land Hit Files? .TRUE.=yes, .FALSE.=no ###NOT ACTIVE 307 | WriteHeaders = .FALSE. ! Write .txt files with column headers? .TRUE.=yes, .FALSE.=no ###NOT ACTIVE 308 | WriteModelTiming = .FALSE. ! Write .csv file with model timing data? .TRUE.=yes, .FALSE.=no ###NOT ACTIVE 309 | 310 | ijbuff = 4 ! number of extra elements to read in on every side of the particles 311 | 312 | FreeSlip = .FALSE. ! enable the use of the free slip condition 313 | 314 | $end 315 | 316 | -------------------------------------------------------------------------------- /boundary_module.f90: -------------------------------------------------------------------------------- 1 | MODULE BOUNDARY_MOD 2 | 3 | ! This module contains variables and subroutines associated with the 4 | ! creation of the land/sea boundaries. The main purpose of this module 5 | ! is to create the land/sea boundaries from a given masked rho grid. 6 | ! The main subroutine in the module, createBounds, determines the number 7 | ! of boundary points, allocates an array of that size, and fills it with 8 | ! the boundary points in order. 9 | ! ROMSPath Version: 1.0.1 10 | 11 | IMPLICIT NONE 12 | PRIVATE 13 | SAVE 14 | 15 | !***************************************************************** 16 | !* VARIABLES * 17 | !***************************************************************** 18 | 19 | 20 | !final boundary variables, after reformatting from bnds 21 | !DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:) :: 22 | !INTEGER, ALLOCATABLE, DIMENSION (:) :: 23 | !DOUBLE PRECISION, ALLOCATABLE, DIMENSION (:,:) :: bnd_x,bnd_y 24 | 25 | !TRUE if the boundary is land, FALSE if it is open ocean 26 | !LOGICAL, ALLOCATABLE, DIMENSION(:) :: land 27 | 28 | INTEGER :: i,j,ng 29 | PUBLIC :: bounds,zbounds 30 | 31 | CONTAINS 32 | 33 | !***************************************************************** 34 | !* FUNCTIONS & SUBROUTINES * 35 | !***************************************************************** 36 | 37 | 38 | !********************************************************* 39 | !* Boundaries * 40 | !********************************************************* 41 | 42 | 43 | SUBROUTINE bounds(ng,Ipar,Jpar,nmask,ingrid,obound) 44 | !This subroutine is for adding boundary points to bnds 45 | ! INPUT: 46 | use grid_mod, only: GRIDS 47 | use param_mod, only: xi_rho,eta_rho 48 | use int_mod, only: inside 49 | IMPLICIT NONE 50 | DOUBLE PRECISION, INTENT(IN) :: Ipar,Jpar 51 | DOUBLE PRECISION :: X,Y,ecut,fcut 52 | DOUBLE PRECISION :: tX(4),tY(4),m(2,2) 53 | INTEGER :: I,J,it,jt,n 54 | LOGICAL :: incell 55 | INTEGER, INTENT(IN) :: ng 56 | INTEGER, INTENT(OUT) :: nmask 57 | LOGICAL, INTENT(OUT) :: ingrid,obound 58 | ecut=0.1 ! POSSIBLY ADD TO PARAM_MOD 59 | fcut=1.0-ecut! POSSIBLY ADD TO PARAM_MOD 60 | ingrid=.FALSE. 61 | obound=.FALSE. 62 | I=floor(Ipar) 63 | J=floor(Jpar) 64 | X=Ipar-dble(I) 65 | Y=Jpar-dble(J) 66 | 67 | 68 | tX=0.0d0 69 | tY=0.0d0 70 | 71 | if ((I.GT.1).and.(J.GT.1).and.(I.LT.(xi_rho(ng)-1)).and.(J.LT.(eta_rho(ng)-1))) then 72 | m(1,1) = GRIDS(ng)%mask_rho(I,J) 73 | m(2,1) = GRIDS(ng)%mask_rho(I+1,J) 74 | m(2,2) = GRIDS(ng)%mask_rho(I+1,J+1) 75 | m(1,2) = GRIDS(ng)%mask_rho(I,J+1) 76 | nmask=m(1,1)+m(2,1)+m(2,2)+m(1,2) 77 | if (nmask.eq.4) then 78 | ingrid=.TRUE. 79 | ! if ((I.EQ.1).or.(J.EQ.1).or.(I.EQ.xi_rho(ng)-1).or.(J.EQ.eta_rho(ng)-1)) then 80 | ! obound=.TRUE. 81 | ! endif 82 | endif 83 | 84 | if (nmask.eq.3) then 85 | n=1 86 | do it=1,2 87 | do jt=1,2 88 | if (m(it,jt).eq.1) then 89 | tX(n)=dble(it)-1.0 90 | tY(n)=dble(jt)-1.0 91 | n=n+1 92 | endif 93 | enddo 94 | enddo 95 | 96 | incell=inside (3, tX, tY, X, Y) 97 | if (incell) then 98 | ingrid=.TRUE. 99 | ! if ((I.EQ.1).or.(J.EQ.1).or.(I.EQ.xi_rho(ng)-1).or.(J.EQ.eta_rho(ng)-1)) then 100 | ! obound=.TRUE. 101 | ! endif 102 | endif 103 | endif 104 | 105 | if (nmask.eq.2) then 106 | if (m(1,1).eq.1) then 107 | if ((X.lt.ecut).and.(Y.lt.ecut)) then 108 | ingrid=.TRUE. 109 | endif 110 | endif 111 | if (m(2,1).eq.1) then 112 | if ((X.gt.fcut).and.(Y.lt.ecut)) then 113 | ingrid=.TRUE. 114 | endif 115 | endif 116 | if (m(2,2).eq.1) then 117 | if ((X.gt.fcut).and.(Y.gt.fcut)) then 118 | ingrid=.TRUE. 119 | endif 120 | endif 121 | if (m(1,2).eq.1) then 122 | if ((X.lt.ecut).and.(Y.gt.fcut)) then 123 | ingrid=.TRUE. 124 | endif 125 | endif 126 | 127 | 128 | endif 129 | 130 | 131 | if ((I.LE.1).or.(J.LE.1).or.(I.GE.xi_rho(ng)-1).or.(J.GE.eta_rho(ng)-1)) then 132 | obound=.TRUE. 133 | endif 134 | 135 | else 136 | 137 | obound=.TRUE. 138 | endif 139 | 140 | 141 | 142 | 143 | END SUBROUTINE bounds 144 | 145 | SUBROUTINE zbounds(ng,Ipar,Jpar,Zpar,ingrid,t) 146 | !This subroutine is for adding boundary points to bnds 147 | ! INPUT: 148 | use grid_mod, only: GRIDS 149 | use param_mod, only: xi_rho,eta_rho 150 | use INT_MOD, only: getInterp2D 151 | IMPLICIT NONE 152 | DOUBLE PRECISION, INTENT(IN) :: Ipar,Jpar 153 | DOUBLE PRECISION, INTENT(INOUT) :: Zpar 154 | INTEGER :: I,J 155 | INTEGER, INTENT(IN) :: ng ,t 156 | LOGICAL, INTENT(OUT) :: ingrid 157 | DOUBLE PRECISION :: tdepth,tzeta 158 | 159 | ingrid=.FALSE. 160 | I=floor(Ipar) 161 | J=floor(Jpar) 162 | if (I.GT.0) then 163 | tdepth = DBLE(-1.0)* getInterp2D("depth",ng,Ipar,Jpar,1) 164 | tzeta = getInterp2D("zeta",ng,Ipar,Jpar,t) 165 | 166 | 167 | if ((Zpar.LT.tzeta).and.(Zpar.GT.tdepth)) then 168 | ingrid=.TRUE. 169 | endif 170 | 171 | if (Zpar.GE.tzeta) then 172 | Zpar=tzeta-0.01D0 !set particle depth to 1 less than 173 | ingrid=.TRUE. 174 | endif 175 | 176 | 177 | endif 178 | 179 | END SUBROUTINE zbounds 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | ! This subroutine calculates the intersection between the particle 188 | ! trajectory and the boundary line in a grid cell, and then calculates 189 | ! the reflection, returning the new particle location 190 | ! subroutine intersect_reflect(Xpos,Ypos,nXpos,nYpos,fintersectX,fintersectY, & 191 | ! freflectX,freflectY,intersectf,skipbound,isWater) 192 | ! IMPLICIT NONE 193 | ! INTEGER, INTENT(OUT) :: intersectf 194 | ! INTEGER, INTENT(INOUT) :: skipbound 195 | ! DOUBLE PRECISION, INTENT(IN) :: Xpos,Ypos,nXpos,nYpos 196 | ! DOUBLE PRECISION, INTENT(OUT) :: fintersectX,fintersectY,freflectX,freflectY 197 | ! LOGICAL, OPTIONAL, INTENT(OUT) :: isWater 198 | ! INTEGER :: i,intersect,skipboundi 199 | ! DOUBLE PRECISION :: crossk,dPBC,mBCperp,rx1,rx2,ry1,ry2,Bp,distBC,dist1, & 200 | ! dist2,intersctx,interscty,rPxyzX,rPxyzY,Mbc,Bbc,Mp,bcx1,bcy1,bcx2,bcy2, & 201 | ! bBCperp,xhigh,xlow,yhigh,ylow,d_Pinter,dtest,bxhigh,bxlow,byhigh,bylow 202 | 203 | ! distBC=0.0 204 | ! Mbc = 0.0 205 | ! Bbc = 0.0 206 | ! Mp = 0.0 207 | ! Bp = 0.0 208 | ! intersect=0 209 | ! intersectf=0 210 | ! skipboundi = skipbound 211 | ! fintersectX = -999999. 212 | ! fintersectY = -999999. 213 | ! freflectX = -999999. 214 | ! freflectY = -999999. 215 | ! dtest = 999999. 216 | ! isWater = .FALSE. 217 | 218 | ! if (Xpos.GE.nXpos) then 219 | ! xhigh = Xpos 220 | ! xlow = nXpos 221 | ! else 222 | ! xhigh = nXpos 223 | ! xlow = Xpos 224 | ! endif 225 | 226 | ! if (Ypos.GE.nYpos) then 227 | ! yhigh = Ypos 228 | ! ylow = nYpos 229 | ! else 230 | ! yhigh = nYpos 231 | ! ylow = Ypos 232 | ! endif 233 | 234 | ! do i=1,nbounds 235 | 236 | ! if (i == skipbound) cycle 237 | 238 | ! intersect = 0 239 | ! bcx1=bnd_x(1,i) 240 | ! bcy1=bnd_y(1,i) 241 | ! bcx2=bnd_x(2,i) 242 | ! bcy2=bnd_y(2,i) 243 | 244 | ! !If the boundary segment end points are both east, west, north, or 245 | ! ! south of the particle's previous or new location, cycle to next 246 | ! ! boundary 247 | ! if( ((bcx1 > xhigh) .AND. (bcx2 > xhigh)) .OR. & 248 | ! ((bcx1 < xlow ) .AND. (bcx2 < xlow )) .OR. & 249 | ! ((bcy1 > yhigh) .AND. (bcy2 > yhigh)) .OR. & 250 | ! ((bcy1 < ylow ) .AND. (bcy2 < ylow )) ) cycle 251 | 252 | ! if (bcx1.GE.bcx2) then 253 | ! bxhigh = bcx1 254 | ! bxlow = bcx2 255 | ! else 256 | ! bxhigh = bcx2 257 | ! bxlow = bcx1 258 | ! endif 259 | 260 | ! if (bcy1.GE.bcy2) then 261 | ! byhigh = bcy1 262 | ! bylow = bcy2 263 | ! else 264 | ! byhigh = bcy2 265 | ! bylow = bcy1 266 | ! endif 267 | 268 | ! !First determine if an undefined denominator is possible 269 | ! if (bcx1.EQ.bcx2 .OR. nXpos.EQ.Xpos ) then 270 | ! !test if they both vertical, if so cycle because they cannot intersect 271 | ! if (bcx1.EQ.bcx2 .AND. nXpos.EQ.Xpos ) cycle 272 | ! !test if perpendicular and parrallel to coordinate axes 273 | ! if (bcx1.EQ.bcx2 .AND. nYpos.EQ.Ypos ) then 274 | ! !undefined denominator, perp. & || to axes 275 | ! intersctx = bcx1 276 | ! interscty = nYpos 277 | ! if (intersctx.LE.xhigh .AND. intersctx.GE.xlow .AND. & 278 | ! interscty.LE.yhigh .AND. interscty.GE.ylow .AND. & 279 | ! intersctx.LE.bxhigh .AND. intersctx.GE.bxlow .AND. & 280 | ! interscty.LE.byhigh .AND. interscty.GE.bylow ) then 281 | ! dPBC=sqrt((intersctx-nXpos)**2+(interscty-nYpos)**2) 282 | ! rx1=nXpos+(DBLE(2.0)*dPBC) 283 | ! ry1=nYpos 284 | ! rx2=nXpos-(DBLE(2.0)*dPBC) 285 | ! ry2=nYpos 286 | ! dist1 = sqrt( (intersctx-rx1)**2 + (interscty-ry1)**2 ) 287 | ! dist2 = sqrt( (intersctx-rx2)**2 + (interscty-ry2)**2 ) 288 | ! if(dist1.LT.dist2) then 289 | ! rPxyzX= rx1 290 | ! rPxyzY= ry1 291 | ! elseif(dist1.GT.dist2) then 292 | ! rPxyzX= rx2 293 | ! rPxyzY= ry2 294 | ! endif 295 | ! intersect=1 296 | ! endif 297 | ! elseif (nXpos.EQ.Xpos .AND. bcy1.EQ.bcy2 ) then 298 | ! !undefined denominator, perp. & || to axes 299 | ! intersctx = nXpos 300 | ! interscty = bcy1 301 | ! if (intersctx.LE.xhigh .AND. intersctx.GE.xlow .AND. & 302 | ! interscty.LE.yhigh .AND. interscty.GE.ylow .AND. & 303 | ! intersctx.LE.bxhigh .AND. intersctx.GE.bxlow .AND. & 304 | ! interscty.LE.byhigh .AND. interscty.GE.bylow ) then 305 | ! dPBC=sqrt((intersctx-nXpos)**2+(interscty-nYpos)**2) 306 | ! rx1=nXpos 307 | ! ry1=nYpos+(DBLE(2.0)*dPBC) 308 | ! rx2=nXpos 309 | ! ry2=nYpos-(DBLE(2.0)*dPBC) 310 | ! dist1 = sqrt( (intersctx-rx1)**2 + (interscty-ry1)**2 ) 311 | ! dist2 = sqrt( (intersctx-rx2)**2 + (interscty-ry2)**2 ) 312 | ! if(dist1.LT.dist2) then 313 | ! rPxyzX= rx1 314 | ! rPxyzY= ry1 315 | ! elseif(dist1.GT.dist2) then 316 | ! rPxyzX= rx2 317 | ! rPxyzY= ry2 318 | ! endif 319 | ! intersect=1 320 | ! endif 321 | ! elseif (bcx1.EQ.bcx2 .AND. nYpos.NE.Ypos ) then 322 | ! !undefined denominator, not perpendicular 323 | ! Mp = (nYpos-Ypos)/(nXpos-Xpos) 324 | ! Bp = Ypos - Mp*Xpos 325 | ! intersctx = bcx1 326 | ! interscty = Mp*intersctx + Bp 327 | ! if (intersctx.LE.xhigh .AND. intersctx.GE.xlow .AND. & 328 | ! interscty.LE.yhigh .AND. interscty.GE.ylow .AND. & 329 | ! intersctx.LE.bxhigh .AND. intersctx.GE.bxlow .AND. & 330 | ! interscty.LE.byhigh .AND. interscty.GE.bylow ) then 331 | ! dPBC = nXpos-intersctx 332 | ! rx1=nXpos+(DBLE(2.0)*dPBC) 333 | ! ry1=nYpos 334 | ! rx2=nXpos-(DBLE(2.0)*dPBC) 335 | ! ry2=nYpos 336 | ! dist1 = sqrt( (intersctx-rx1)**2 + (interscty-ry1)**2 ) 337 | ! dist2 = sqrt( (intersctx-rx2)**2 + (interscty-ry2)**2 ) 338 | ! if(dist1.LT.dist2) then 339 | ! rPxyzX= rx1 340 | ! rPxyzY= ry1 341 | ! elseif(dist1.GT.dist2) then 342 | ! rPxyzX= rx2 343 | ! rPxyzY= ry2 344 | ! endif 345 | ! intersect=1 346 | ! endif 347 | ! elseif (nXpos.EQ.Xpos .AND. bcy1.NE.bcy2 ) then 348 | ! !undefined denominator, not perpendicular 349 | ! Mbc = (bcy2-bcy1)/(bcx2-bcx1) 350 | ! Bbc = bcy2 - Mbc*bcx2 351 | ! intersctx = nXpos 352 | ! interscty = Mbc*intersctx + Bbc 353 | ! if (intersctx.LE.xhigh .AND. intersctx.GE.xlow .AND. & 354 | ! interscty.LE.yhigh .AND. interscty.GE.ylow .AND. & 355 | ! intersctx.LE.bxhigh .AND. intersctx.GE.bxlow .AND. & 356 | ! interscty.LE.byhigh .AND. interscty.GE.bylow ) then 357 | ! !Now use cross product to determine the distance of the particle 358 | ! ! from the boundary 359 | ! distBC = sqrt((bcx1-bcx2)**2+(bcy1-bcy2)**2) 360 | ! crossk= ((nXpos-bcx1)*(bcy2-bcy1)) - ((bcx2-bcx1)*(nYpos-bcy1)) 361 | ! dPBC = sqrt(crossk**2)/distBC 362 | ! !find line perpendicular to boundary 363 | ! mBCperp = DBLE(-1.0)/Mbc 364 | ! bBCperp = nYpos - mBCperp*nXpos 365 | ! !find two potential reflection points 366 | ! rx1 = sqrt( ((DBLE(2.0)*dPBC)**2)/(DBLE(1.0)+mBCperp**2) ) +nXpos 367 | ! ry1 = mBCperp*rx1 + bBCperp 368 | ! rx2 = sqrt( ((DBLE(2.0)*dPBC)**2)/(DBLE(1.0)+mBCperp**2) ) & 369 | ! * DBLE(-1.0) + nXpos 370 | ! ry2 = mBCperp*rx2 + bBCperp 371 | ! !point closest to intersection of boundary and particle trajectory 372 | ! ! is the right one 373 | ! dist1 = sqrt( (intersctx-rx1)**2 + (interscty-ry1)**2 ) 374 | ! dist2 = sqrt( (intersctx-rx2)**2 + (interscty-ry2)**2 ) 375 | ! if(dist1.LT.dist2) then 376 | ! rPxyzX= rx1 377 | ! rPxyzY= ry1 378 | ! elseif(dist1.GT.dist2) then 379 | ! rPxyzX= rx2 380 | ! rPxyzY= ry2 381 | ! endif 382 | ! intersect=1 383 | ! endif 384 | ! endif 385 | ! else 386 | 387 | ! if(intersect == 0)then 388 | 389 | ! Mbc = (bcy2-bcy1)/(bcx2-bcx1) 390 | ! Bbc = bcy2 - Mbc*bcx2 391 | ! Mp = (nYpos-Ypos)/(nXpos-Xpos) 392 | ! Bp = Ypos - Mp*Xpos 393 | ! intersctx = (Bbc - Bp)/(Mp - Mbc) 394 | ! interscty = Mp*intersctx + Bp 395 | 396 | ! !when bc parallel with x-axis, byhigh=bylow=intersecty 397 | ! if (Mbc.EQ.0.0) interscty = byhigh 398 | 399 | ! if (intersctx.LE.xhigh .AND. intersctx.GE.xlow .AND. & 400 | ! interscty.LE.yhigh .AND. interscty.GE.ylow .AND. & 401 | ! intersctx.LE.bxhigh .AND. intersctx.GE.bxlow .AND. & 402 | ! interscty.LE.byhigh .AND. interscty.GE.bylow ) then 403 | 404 | ! if (Mbc.EQ.0.0) then !inverse slope denominator not OK 405 | ! dPBC = nYpos-bcy1 406 | ! rx1=nXpos 407 | ! ry1=nYpos+(DBLE(2.0)*dPBC) 408 | ! rx2=nXpos 409 | ! ry2=nYpos-(DBLE(2.0)*dPBC) 410 | ! dist1 = sqrt( (intersctx-rx1)**2 + (interscty-ry1)**2 ) 411 | ! dist2 = sqrt( (intersctx-rx2)**2 + (interscty-ry2)**2 ) 412 | ! if(dist1.LT.dist2) then 413 | ! rPxyzX= rx1 414 | ! rPxyzY= ry1 415 | ! elseif(dist1.GT.dist2) then 416 | ! rPxyzX= rx2 417 | ! rPxyzY= ry2 418 | ! endif 419 | ! intersect=1 420 | ! endif 421 | 422 | ! if(intersect == 0)then 423 | 424 | ! !Now use cross product to determine the distance of the 425 | ! ! particle from the boundary 426 | ! distBC = sqrt((bcx1-bcx2)**2+(bcy1-bcy2)**2) 427 | ! crossk= ((nXpos-bcx1)*(bcy2-bcy1)) - ((bcx2-bcx1)*(nYpos-bcy1)) 428 | ! dPBC = sqrt(crossk**2)/distBC 429 | ! !find line perpendicular to boundary 430 | ! mBCperp = DBLE(-1.0)/Mbc 431 | ! bBCperp = nYpos - mBCperp*nXpos 432 | ! !find two potential reflection points 433 | ! rx1 = sqrt(((DBLE(2.0)*dPBC)**2)/(DBLE(1.0)+mBCperp**2)) +nXpos 434 | ! ry1 = mBCperp*rx1 + bBCperp 435 | ! rx2 = sqrt(((DBLE(2.0)*dPBC)**2)/(DBLE(1.0)+mBCperp**2)) & 436 | ! * DBLE(-1.0) + nXpos 437 | ! ry2 = mBCperp*rx2 + bBCperp 438 | ! !point closest to intersection of boundary and particle 439 | ! ! trajectory is the right one 440 | ! dist1 = sqrt( (intersctx-rx1)**2 + (interscty-ry1)**2 ) 441 | ! dist2 = sqrt( (intersctx-rx2)**2 + (interscty-ry2)**2 ) 442 | ! if(dist1.LT.dist2) then 443 | ! rPxyzX= rx1 444 | ! rPxyzY= ry1 445 | ! elseif(dist1.GT.dist2) then 446 | ! rPxyzX= rx2 447 | ! rPxyzY= ry2 448 | ! endif 449 | ! intersect=1 450 | 451 | ! endif 452 | ! endif 453 | ! endif 454 | ! endif 455 | 456 | 457 | ! d_Pinter = sqrt( (Xpos-intersctx)**2 + (Ypos-interscty)**2 ) 458 | ! if( (intersect .EQ. 1) .AND. (d_Pinter .LT. dtest) ) then 459 | ! fintersectX = intersctx 460 | ! fintersectY = interscty 461 | ! freflectX = rPxyzX 462 | ! freflectY = rPxyzY 463 | ! intersectf = 1 464 | ! dtest = d_Pinter 465 | ! skipboundi = i 466 | ! isWater = .NOT. land(i) 467 | ! endif 468 | 469 | ! enddo 470 | 471 | ! skipbound = skipboundi 472 | ! END SUBROUTINE intersect_reflect 473 | 474 | 475 | 476 | 477 | END MODULE 478 | -------------------------------------------------------------------------------- /CROCO/grid_module.f90: -------------------------------------------------------------------------------- 1 | MODULE GRID_MOD 2 | 3 | ! Grid MOdule 4 | 5 | ! ROMSPath Version: 1.0.1 6 | 7 | IMPLICIT NONE 8 | PUBLIC 9 | SAVE 10 | 11 | 12 | DOUBLE PRECISION :: reftime 13 | CHARACTER(len=100) :: time_units 14 | TYPE GRIDDATA 15 | DOUBLE PRECISION,pointer :: s_rho(:) 16 | DOUBLE PRECISION,pointer :: s_w(:) 17 | DOUBLE PRECISION,pointer :: cs_r(:) 18 | DOUBLE PRECISION,pointer :: cs_w(:) 19 | DOUBLE PRECISION,pointer :: H(:,:) 20 | DOUBLE PRECISION,pointer :: lon_rho(:,:) 21 | DOUBLE PRECISION,pointer :: lat_rho(:,:) 22 | DOUBLE PRECISION,pointer :: xi(:,:) 23 | DOUBLE PRECISION,pointer :: eta(:,:) 24 | DOUBLE PRECISION,pointer :: pm(:,:) 25 | DOUBLE PRECISION,pointer :: pn(:,:) 26 | DOUBLE PRECISION,pointer :: angle(:,:) 27 | DOUBLE PRECISION,pointer :: scl(:,:) 28 | DOUBLE PRECISION,pointer :: off(:,:) 29 | DOUBLE PRECISION,pointer :: z_rho(:,:,:) 30 | DOUBLE PRECISION,pointer :: z_w(:,:,:) 31 | INTEGER,pointer :: mask_rho(:,:) 32 | INTEGER,pointer :: mask_u(:,:) 33 | INTEGER,pointer :: mask_v(:,:) 34 | END TYPE GRIDDATA 35 | TYPE (GRIDDATA), allocatable :: GRIDS(:) 36 | PUBLIC ::GRIDS 37 | CONTAINS 38 | 39 | 40 | SUBROUTINE InitGrid() 41 | 42 | 43 | USE netcdf 44 | USE PARAM_MOD, ONLY: xi_rho,eta_rho,xi_u,eta_u,xi_v,eta_v, & 45 | s_rho,s_w,Vtransform,Vstretching,theta_s,theta_b,tline,zob, & 46 | prefix,suffix,filenum,numdigits,Ngrid,refine,hc,time_vname 47 | USE HYDRO_MOD, ONLY: getFileNames 48 | IMPLICIT NONE 49 | 50 | ! INTEGER, INTENT(OUT), OPTIONAL :: IOSTAT 51 | 52 | INCLUDE 'netcdf.inc' 53 | 54 | !NetCDF Variables 55 | INTEGER :: NCID,STATUS,VID,dimid,dimcount,ng,ng2,nref,dng 56 | 57 | CHARACTER(len=200) :: filenm,header 58 | CHARACTER(len=100) :: strtmp 59 | DOUBLE PRECISION :: grefine(Ngrid,Ngrid) 60 | !Grid File Output Variables 61 | ! INTEGER :: nR,nU,nV,maxR,maxU,maxV,wetR,wetU,wetV 62 | 63 | !Iteration Variables 64 | INTEGER :: i,j,err,ii,jj 65 | 66 | err = 0 67 | header="PROBLEM READING GRID INFORMATION" 68 | ! *********************** GET GRID INFO *********************** 69 | 70 | ! OPEN NETCDF FILE - GET NCID VALUE 71 | do ng=1,Ngrid 72 | if (ng.eq.1) allocate(GRIDS(Ngrid)) 73 | 74 | call getFileNames(filenm,prefix(ng),filenum) 75 | 76 | 77 | 78 | STATUS = NF90_OPEN(filenm,NF90_NOWRITE,NCID) 79 | if (STATUS .NE. NF90_NOERR) then 80 | write(*,*) 'Problem with NF90_OPEN:' 81 | write(*,*) 'File not found:' 82 | write(*,*) filenm 83 | err = 10 84 | call errorHandler(header,-1) 85 | endif 86 | 87 | ! GET VALUES FOR xi_rho,xi_u,xi_v,eta_rho,eta_u,eta_v 88 | 89 | STATUS = NF90_INQ_DIMID(NCID,'xi_rho',dimid) 90 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 91 | if (STATUS .NE. NF90_NOERR) then 92 | write(*,*) 'Problem dimid xi_rho' 93 | err = 20 94 | call errorHandler(header,-1) 95 | endif 96 | xi_rho(ng) = dimcount 97 | 98 | STATUS = NF90_INQ_DIMID(NCID,'eta_rho',dimid) 99 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 100 | if (STATUS .NE. NF90_NOERR) then 101 | write(*,*) 'Problem dimid eta_rho' 102 | err = 20 103 | call errorHandler(header,-1) 104 | endif 105 | eta_rho(ng) = dimcount 106 | !print *, eta_rho(ng) !ELI 107 | !print *, dimcount !ELI 108 | 109 | STATUS = NF90_INQ_DIMID(NCID,'xi_u',dimid) 110 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 111 | if (STATUS .NE. NF90_NOERR) then 112 | write(*,*) 'Problem dimid xi_u' 113 | err = 20 114 | call errorHandler(header,-1) 115 | endif 116 | xi_u(ng) = dimcount 117 | 118 | !STATUS = NF90_INQ_DIMID(NCID,'eta_u',dimid) 119 | STATUS = NF90_INQ_DIMID(NCID,'eta_rho',dimid) !ELI 120 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 121 | if (STATUS .NE. NF90_NOERR) then 122 | write(*,*) 'Problem dimid eta_u' 123 | err = 20 124 | call errorHandler(header,-1) 125 | endif 126 | eta_u(ng) = dimcount 127 | 128 | !STATUS = NF90_INQ_DIMID(NCID,'xi_v',dimid) 129 | STATUS = NF90_INQ_DIMID(NCID,'xi_rho',dimid) !ELI 130 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 131 | if (STATUS .NE. NF90_NOERR) then 132 | write(*,*) 'Problem dimid xi_v' 133 | call errorHandler(header,-1) 134 | err = 20 135 | endif 136 | xi_v(ng) = dimcount 137 | 138 | STATUS = NF90_INQ_DIMID(NCID,'eta_v',dimid) 139 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 140 | if (STATUS .NE. NF90_NOERR) then 141 | write(*,*) 'Problem dimid eta_v' 142 | call errorHandler(header,-1) 143 | err = 20 144 | endif 145 | eta_v(ng) = dimcount 146 | 147 | STATUS = NF90_INQ_DIMID(NCID,'s_rho',dimid) 148 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 149 | if (STATUS .NE. NF90_NOERR) then 150 | write(*,*) 'Problem dimid s_rho' 151 | call errorHandler(header,-1) 152 | err = 20 153 | endif 154 | s_rho(ng) = dimcount 155 | 156 | STATUS = NF90_INQ_DIMID(NCID,'s_w',dimid) 157 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 158 | if (STATUS .NE. NF90_NOERR) then 159 | write(*,*) 'Problem dimid s_w' 160 | call errorHandler(header,-1) 161 | err = 20 162 | endif 163 | s_w(ng) = dimcount 164 | 165 | 166 | ! READ IN Grid vertical trasnformation paramters 167 | 168 | STATUS = NF90_INQ_VARID(NCID,'Vtransform',VID) 169 | STATUS = NF90_GET_VAR(NCID,VID,Vtransform(ng)) 170 | if (STATUS .NE. NF90_NOERR) then 171 | write(*,*) 'Problem read Vtransform' 172 | err = 40 173 | call errorHandler(header,-1) 174 | endif 175 | 176 | STATUS = NF90_INQ_VARID(NCID,'Vstretching',VID) 177 | STATUS = NF90_GET_VAR(NCID,VID,Vstretching(ng)) 178 | if (STATUS .NE. NF90_NOERR) then 179 | write(*,*) 'Problem read Vstretching' 180 | err = 40 181 | call errorHandler(header,-1) 182 | endif 183 | 184 | STATUS = NF90_INQ_VARID(NCID,'theta_s',VID) 185 | STATUS = NF90_GET_VAR(NCID,VID,theta_s(ng)) 186 | if (STATUS .NE. NF90_NOERR) then 187 | write(*,*) 'Problem read theta_s' 188 | err = 40 189 | call errorHandler(header,-1) 190 | endif 191 | 192 | STATUS = NF90_INQ_VARID(NCID,'theta_b',VID) 193 | STATUS = NF90_GET_VAR(NCID,VID,theta_b(ng)) 194 | if (STATUS .NE. NF90_NOERR) then 195 | write(*,*) 'Problem read theta_b' 196 | err = 40 197 | call errorHandler(header,-1) 198 | endif 199 | 200 | STATUS = NF90_INQ_VARID(NCID,'hc',VID) 201 | STATUS = NF90_GET_VAR(NCID,VID,hc(ng)) 202 | if (STATUS .NE. NF90_NOERR) then 203 | write(*,*) 'Problem read hc' 204 | err = 40 205 | call errorHandler(header,-1) 206 | endif 207 | 208 | ! ! ALLOCATE VARIABLE ARRAY DIMENSIONS 209 | ALLOCATE(GRIDS(ng)%mask_rho(xi_rho(ng),eta_rho(ng))) 210 | ALLOCATE(GRIDS(ng)%H(xi_rho(ng),eta_rho(ng))) 211 | ALLOCATE(GRIDS(ng)%angle(xi_rho(ng),eta_rho(ng))) 212 | ALLOCATE(GRIDS(ng)%lon_rho(xi_rho(ng),eta_rho(ng))) 213 | ALLOCATE(GRIDS(ng)%lat_rho(xi_rho(ng),eta_rho(ng))) 214 | ALLOCATE(GRIDS(ng)%pm(xi_rho(ng),eta_rho(ng))) 215 | ALLOCATE(GRIDS(ng)%pn(xi_rho(ng),eta_rho(ng))) 216 | ALLOCATE(GRIDS(ng)%mask_u(xi_u(ng),eta_u(ng))) 217 | ALLOCATE(GRIDS(ng)%mask_v(xi_v(ng),eta_v(ng))) 218 | ALLOCATE(GRIDS(ng)%s_rho(s_rho(ng))) 219 | ALLOCATE(GRIDS(ng)%s_w(s_w(ng))) 220 | ALLOCATE(GRIDS(ng)%cs_r(s_rho(ng))) 221 | ALLOCATE(GRIDS(ng)%cs_w(s_w(ng))) 222 | ALLOCATE(GRIDS(ng)%z_w(s_w(ng),Ngrid,3)) 223 | ALLOCATE(GRIDS(ng)%z_rho(s_rho(ng),Ngrid,3)) 224 | ALLOCATE(GRIDS(ng)%xi(xi_rho(ng),eta_rho(ng))) 225 | ALLOCATE(GRIDS(ng)%eta(xi_rho(ng),eta_rho(ng))) 226 | ALLOCATE(GRIDS(ng)%scl(Ngrid,2)) 227 | ALLOCATE(GRIDS(ng)%off(Ngrid,2)) 228 | 229 | 230 | 231 | ! READ IN DATA FROM NETCDF FILE TO VARIABLES 232 | 233 | 234 | ! rho grid mask 235 | STATUS = NF90_INQ_VARID(NCID,'mask_rho',VID) 236 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%mask_rho) 237 | if (STATUS .NE. NF90_NOERR) then 238 | write(*,*) 'Problem read mask_rho' 239 | err = 40 240 | call errorHandler(header,-1) 241 | endif 242 | 243 | ! u grid mask 244 | STATUS = NF90_INQ_VARID(NCID,'mask_u',VID) 245 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%mask_u) 246 | if(STATUS .NE. NF90_NOERR) then 247 | write(*,*)'Problem read mask_u' 248 | err = 40 249 | call errorHandler(header,-1) 250 | endif 251 | 252 | ! v grid mask 253 | STATUS = NF90_INQ_VARID(NCID,'mask_v',VID) 254 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%mask_v) 255 | if(STATUS .NE. NF90_NOERR) then 256 | write(*,*)'Problem read mask_v' 257 | err = 40 258 | call errorHandler(header,-1) 259 | endif 260 | 261 | ! Longitude 262 | STATUS = NF90_INQ_VARID(NCID,'lon_rho',VID) 263 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%lon_rho) 264 | if(STATUS .NE. NF90_NOERR) then 265 | write(*,*)'Problem read lon_rho' 266 | err = 40 267 | call errorHandler(header,-1) 268 | endif 269 | 270 | ! Latitude 271 | STATUS = NF90_INQ_VARID(NCID,'lat_rho',VID) 272 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%lat_rho) 273 | if(STATUS .NE. NF90_NOERR) then 274 | write(*,*)'Problem read lat_rho' 275 | err = 40 276 | call errorHandler(header,-1) 277 | endif 278 | 279 | ! Latitude 280 | STATUS = NF90_INQ_VARID(NCID,'h',VID) 281 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%H) 282 | if(STATUS .NE. NF90_NOERR) then 283 | write(*,*)'Problem read H' 284 | err = 40 285 | call errorHandler(header,-1) 286 | endif 287 | ! PM 288 | STATUS = NF90_INQ_VARID(NCID,'pm',VID) 289 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%pm) 290 | if(STATUS .NE. NF90_NOERR) then 291 | write(*,*)'Problem read pm' 292 | err = 40 293 | call errorHandler(header,-1) 294 | endif 295 | ! PN 296 | STATUS = NF90_INQ_VARID(NCID,'pn',VID) 297 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%pn) 298 | if(STATUS .NE. NF90_NOERR) then 299 | write(*,*)'Problem read pn' 300 | err = 40 301 | call errorHandler(header,-1) 302 | endif 303 | ! Angle 304 | STATUS = NF90_INQ_VARID(NCID,'angle',VID) 305 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%angle) 306 | if(STATUS .NE. NF90_NOERR) then 307 | write(*,*)'Problem read pn' 308 | err = 40 309 | call errorHandler(header,-1) 310 | endif 311 | 312 | STATUS = NF90_INQ_VARID(NCID,'s_rho',VID) 313 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%s_rho) 314 | if (STATUS .NE. NF90_NOERR) then 315 | write(*,*) 'Problem read s_rho' 316 | write(*,*) NF90_STRERROR(STATUS) 317 | call errorHandler(header,-1) 318 | endif 319 | 320 | ! Cs value on rho grid (Cs_r) 321 | STATUS = NF90_INQ_VARID(NCID,'Cs_r',VID) 322 | 323 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%cs_r) 324 | if (STATUS .NE. NF90_NOERR) then 325 | write(*,*) 'Problem read CS_r' 326 | write(*,*) NF90_STRERROR(STATUS) 327 | call errorHandler(header,-1) 328 | endif 329 | ! s-coordinate on w grid (sc_w) 330 | STATUS = NF90_INQ_VARID(NCID,'s_w',VID) 331 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%s_w) 332 | if (STATUS .NE. NF90_NOERR) then 333 | write(*,*) 'Problem read s_w' 334 | write(*,*) NF90_STRERROR(STATUS) 335 | call errorHandler(header,-1) 336 | endif 337 | ! Cs value on w grid (Cs_w) 338 | STATUS = NF90_INQ_VARID(NCID,'Cs_w',VID) 339 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%cs_w) 340 | if (STATUS .NE. NF90_NOERR) then 341 | write(*,*) 'Problem read cs_w' 342 | write(*,*) NF90_STRERROR(STATUS) 343 | call errorHandler(header,-1) 344 | endif 345 | ! Ocean_time 346 | STATUS = NF90_INQ_VARID(NCID,trim(time_vname),VID) 347 | STATUS = NF90_GET_VAR(NCID,VID,reftime) 348 | if (STATUS .NE. NF90_NOERR) then 349 | write(*,*) 'Problem reading Time variable:' 350 | write(*,*) trim(time_vname) 351 | write(*,*) NF90_STRERROR(STATUS) 352 | call errorHandler(header,-1) 353 | endif 354 | 355 | 356 | 357 | STATUS = nf90_get_att(NCID, VID,'units', strtmp) 358 | if (STATUS .NE. NF90_NOERR) then 359 | write(*,*) 'NO time units' 360 | write(*,*) NF90_STRERROR(STATUS) 361 | call errorHandler(header,-1) 362 | endif 363 | 364 | 365 | if(index(strtmp,'days') .gt. 0)then 366 | reftime=reftime*dble(86400.0) 367 | write(*,*) 'time units in input file are days' 368 | time_units(1:7)='seconds' 369 | time_units(8:100)=strtmp(5:100-3) 370 | elseif(index(strtmp,'hours') .gt. 0)then 371 | write(*,*) 'time units in input file are hours' 372 | reftime=reftime*dble(3600.0) 373 | time_units(1:7)='seconds' 374 | time_units(8:100)=strtmp(6:100-2) 375 | elseif(index(strtmp,'minutes') .gt. 0)then 376 | reftime=reftime*dble(60.0) 377 | write(*,*) 'time units in input file are minutes' 378 | time_units(1:7)='seconds' 379 | time_units(8:100)=strtmp(8:100) 380 | !elseif(index(strtmp,'seconds') .gt. 0)then 381 | elseif(index(strtmp,'second') .gt. 0)then !ELI 382 | write(*,*) 'time units in input file are seconds' 383 | time_units=strtmp 384 | else 385 | write(*,*) 'Not a recognized time unit' 386 | call errorHandler(header,-1) 387 | endif 388 | STATUS = NF90_CLOSE(NCID) 389 | if(STATUS /= NF90_NOERR) then 390 | write(*,*)'Problem closing NCID' 391 | err = 50 392 | call errorHandler(header,-1) 393 | endif 394 | 395 | 396 | write(*,*) time_units 397 | write(*,*) reftime 398 | 399 | ! ********************** MAKE Xi,eta griod ********************** 400 | 401 | do i=1,xi_rho(ng) 402 | do j=1,eta_rho(ng) 403 | GRIDS(ng)%xi(i,j)=i 404 | GRIDS(ng)%eta(i,j)=j 405 | enddo 406 | enddo 407 | 408 | 409 | GRIDS(ng)%scl=1.0d0 410 | GRIDS(ng)%off=0.0d0 411 | grefine=1.0d0 412 | enddo 413 | do ng=1,Ngrid 414 | do ng2=1,Ngrid 415 | dng=abs(ng-ng2) 416 | if (dng.GT.0.0) then 417 | do nref=1,dng 418 | grefine(ng,ng2)=refine(dng)*grefine(ng,ng2) 419 | enddo 420 | endif 421 | enddo 422 | enddo 423 | 424 | !!!!!!!!!!!THIS IS a bit kludgy. 425 | !!!!! setting scales and offsets for coordinate transform. 426 | do ng2=1,Ngrid 427 | do ng=1,Ngrid 428 | loop1:do i=1,xi_rho(ng) 429 | do j=1,eta_rho(ng) 430 | do ii=1,xi_rho(ng2) 431 | do jj=1,eta_rho(ng2) 432 | if ((GRIDS(ng)%lon_rho(i,j).EQ.GRIDS(ng2)%lon_rho(ii,jj)).and. & 433 | (GRIDS(ng)%lat_rho(i,j).EQ.GRIDS(ng2)%lat_rho(ii,jj))) then 434 | 435 | exit loop1 436 | endif 437 | enddo 438 | enddo 439 | enddo 440 | enddo loop1 441 | GRIDS(ng)%scl(ng2,:)=1.0d0/grefine(ng,ng2) 442 | GRIDS(ng2)%scl(ng,:)=grefine(ng2,ng) 443 | 444 | GRIDS(ng)%off(ng2,1)=dble(ii)-GRIDS(ng)%scl(ng2,1)*dble(i) 445 | GRIDS(ng)%off(ng2,2)=dble(jj)-GRIDS(ng)%scl(ng2,2)*dble(j) 446 | GRIDS(ng2)%off(ng,1)=dble(i)-GRIDS(ng2)%scl(ng,1)*dble(ii) 447 | GRIDS(ng2)%off(ng,2)=dble(j)-GRIDS(ng2)%scl(ng,2)*dble(jj) 448 | 449 | 450 | 451 | 452 | enddo 453 | enddo 454 | 455 | ! do ng=1,Ngrid 456 | ! write(*,*) '1--------------' 457 | ! do ng2=1,Ngrid 458 | ! write(*,*) ng,ng2 459 | ! write(*,*) grefine(ng,ng2) 460 | ! write(*,*) GRIDS(ng)%off(ng2,1),GRIDS(ng2)%off(ng,2) 461 | ! write(*,*) GRIDS(ng)%scl(ng2,1),GRIDS(ng2)%scl(ng,2) 462 | 463 | ! enddo 464 | ! enddo 465 | !If IOSTAT is present, set return value to error code 466 | !IF(PRESENT(IOSTAT)) IOSTAT = err 467 | ! 0=No Errors 30=Error allocating arrays 468 | ! 10=Error Opening NCgridfile 40=Error getting variables 469 | ! 20=Error getting dimensions 50=Error Closing NCgridfile 470 | 471 | END SUBROUTINE InitGrid 472 | 473 | SUBROUTINE errorHandler(header, flag) 474 | IMPLICIT NONE 475 | CHARACTER(LEN=120), INTENT(IN) :: header 476 | INTEGER, INTENT(IN) :: flag 477 | 478 | WRITE(*,"(A120)")header !print error message in report.txt 479 | STOP 480 | 481 | 482 | END SUBROUTINE errorHandler 483 | 484 | 485 | DOUBLE PRECISION FUNCTION getSlevel(zeta,depth,ng,i) 486 | !This function returns the depth of the current s-level 487 | USE PARAM_MOD, ONLY: s_rho,s_w,Vtransform,Vstretching,hc 488 | IMPLICIT NONE 489 | INTEGER, INTENT(IN) :: ng,i 490 | DOUBLE PRECISION, INTENT(IN) :: zeta,depth 491 | DOUBLE PRECISION :: h,S 492 | 493 | 494 | ! convert negative depth to positive depth 495 | h = DBLE(-1.0) * depth 496 | 497 | 498 | SELECT CASE(Vtransform(ng)) 499 | 500 | CASE(1) !Rutgers-ROMS formulation, eqn (1) of 501 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 502 | 503 | S = hc(ng)*GRIDS(ng)%s_rho(i)+(h-hc(ng))*GRIDS(ng)%cs_r(i) 504 | getSlevel = S+zeta*(DBLE(1.0)+S/h) 505 | 506 | CASE(2) !UCLA-formulation, eqn(2) of 507 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 508 | 509 | S = (hc(ng)*GRIDS(ng)%s_rho(i)+h*GRIDS(ng)%cs_r(i)) / (hc(ng)+h) 510 | getSlevel = zeta+(zeta+h)*S 511 | 512 | CASE(3) !Song, Y. and D. B. Haidvogel, 1994: A semi-implicit 513 | !ocean circulation model using a generalized topography-following 514 | !coordinate system, J. Comp. Phys., 115 (1), 228-244. 515 | 516 | getSlevel = zeta*(DBLE(1.0)+GRIDS(ng)%s_rho(i))+hc(ng)*GRIDS(ng)%s_rho(i)+(h-hc(ng))*GRIDS(ng)%cs_r(i) 517 | 518 | CASE DEFAULT 519 | write(*,*) 'ERROR: Illegal Vtransform number' 520 | write(*,*) ' ' 521 | write(*,*) 'The Program Cannot Continue and Will Terminate' 522 | stop 523 | 524 | END SELECT 525 | 526 | END FUNCTION getSlevel 527 | 528 | 529 | DOUBLE PRECISION FUNCTION getWlevel(zeta,depth,ng,i) 530 | !This function returns the depth of the current s-level 531 | USE PARAM_MOD, ONLY: s_rho,s_w,Vtransform,Vstretching,hc 532 | IMPLICIT NONE 533 | INTEGER, INTENT(IN) :: ng,i 534 | DOUBLE PRECISION, INTENT(IN) :: zeta,depth 535 | DOUBLE PRECISION :: h,S 536 | 537 | 538 | ! convert negative depth to positive depth 539 | h = DBLE(-1.0) * depth 540 | 541 | 542 | SELECT CASE(Vtransform(ng)) 543 | 544 | CASE(1) !Rutgers-ROMS formulation, eqn (1) of 545 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 546 | 547 | S = hc(ng)*GRIDS(ng)%s_w(i)+(h-hc(ng))*GRIDS(ng)%cs_w(i) 548 | getWlevel = S+zeta*(DBLE(1.0)+S/h) 549 | 550 | CASE(2) !UCLA-formulation, eqn(2) of 551 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 552 | 553 | S = (hc(ng)*GRIDS(ng)%s_w(i)+h*GRIDS(ng)%cs_w(i)) / (hc(ng)+h) 554 | getWlevel = zeta+(zeta+h)*S 555 | 556 | CASE(3) !Song, Y. and D. B. Haidvogel, 1994: A semi-implicit 557 | !ocean circulation model using a generalized topography-following 558 | !coordinate system, J. Comp. Phys., 115 (1), 228-244. 559 | 560 | getWlevel = zeta*(DBLE(1.0)+GRIDS(ng)%s_w(i))+hc(ng)*GRIDS(ng)%s_w(i)+(h-hc(ng))*GRIDS(ng)%cs_w(i) 561 | 562 | CASE DEFAULT 563 | write(*,*) 'ERROR: Illegal Vtransform number' 564 | write(*,*) ' ' 565 | write(*,*) 'The Program Cannot Continue and Will Terminate' 566 | stop 567 | 568 | END SELECT 569 | 570 | END FUNCTION getWlevel 571 | 572 | 573 | END MODULE GRID_MOD 574 | -------------------------------------------------------------------------------- /ROMSPath.h: -------------------------------------------------------------------------------- 1 | ! 2 | !This file defines many variables that are read from the GRID.data and ROMSPath.data files 3 | !And also groups the input parameters/variables into namelists 4 | ! 5 | !NOTE: variables in a namelist can NOT be dynamic variables!!!!! 6 | ! dynamic namelists are NOT yet supported in FORTRAN90/95 standard 7 | ! 8 | ! ROMSPath Version: 1.0.1 9 | 10 | INTEGER,parameter :: MAXNgrid=5 11 | DOUBLE PRECISION,parameter :: Eradius = 6371315.0D0 12 | DOUBLE PRECISION, parameter :: pi = 3.14159265358979323846D0 13 | DOUBLE PRECISION, parameter :: deg2rad = pi / 180.0D0 14 | DOUBLE PRECISION, parameter :: rad2deg =180.0D0 / pi 15 | DOUBLE PRECISION, parameter :: g =980D0 ! cm s^-2 Gravity 16 | DOUBLE PRECISION, parameter :: rhof =1.026D0 ! (g cm^-3) Density 17 | DOUBLE PRECISION, parameter :: nu =0.01D0 ! (cm^2 s^-1) kinematic viscosity of seawater 18 | DOUBLE PRECISION, parameter :: mu =0.010260D0 ! (g cm^-1 s^-1) dynamic viscosity of seawater(nu*rhof) 19 | DOUBLE PRECISION, parameter :: rhop =1.06D0 ! (g cm^-3) Density of larva 20 | 21 | 22 | !--these are the grid dimension/paramters read from the history/averages files. 23 | 24 | INTEGER :: xi_rho(MAXNgrid) ! 25 | INTEGER :: eta_rho(MAXNgrid) ! 26 | INTEGER :: xi_u(MAXNgrid) ! 27 | INTEGER :: eta_u(MAXNgrid) ! 28 | INTEGER :: xi_v(MAXNgrid) ! 29 | INTEGER :: eta_v(MAXNgrid) ! 30 | INTEGER :: s_rho(MAXNgrid) ! 31 | INTEGER :: s_w(MAXNgrid) ! 32 | INTEGER :: Vtransform(MAXNgrid) ! 33 | INTEGER :: Vstretching(MAXNgrid) ! 34 | INTEGER :: theta_s(MAXNgrid) ! 35 | INTEGER :: theta_b(MAXNgrid) ! 36 | INTEGER :: tline(MAXNgrid) ! 37 | INTEGER :: zob(MAXNgrid) ! 38 | INTEGER :: tdim(MAXNgrid) ! 39 | INTEGER :: t_b 40 | INTEGER :: t_c 41 | INTEGER :: t_f 42 | INTEGER :: tstep 43 | DOUBLE PRECISION :: hc(MAXNgrid) 44 | 45 | ! INTEGER :: rho_nodes(MAXNgrid) ! number rho nodes 46 | ! INTEGER :: u_nodes(MAXNgrid) ! number of u nodes 47 | ! INTEGER :: v_nodes(MAXNgrid) ! number of v nodes! 48 | 49 | ! INTEGER :: max_rho_elements(MAXNgrid) ! total number of rho elements 50 | ! INTEGER :: max_u_elements(MAXNgrid) ! total number of u elements 51 | ! INTEGER :: max_v_elements(MAXNgrid) ! total v 52 | 53 | ! INTEGER :: rho_elements(MAXNgrid) ! number of rho elements with at least 1 vertex is water 54 | ! INTEGER :: u_elements(MAXNgrid) ! u 55 | ! INTEGER :: v_elements(MAXNgrid) ! v 56 | 57 | !group the grid info section in a namelist: 58 | 59 | namelist/gridinfo/ xi_rho,eta_rho,xi_u,eta_u,xi_v,eta_v,t_b,t_c,t_f,tstep, & 60 | & s_rho,s_w,Vtransform,Vstretching,theta_s,theta_b,tline,zob 61 | 62 | 63 | 64 | !The following used to be in ROMSPath.inc: 65 | 66 | 67 | !*** NUMBER OF PARTICLES *** 68 | 69 | INTEGER :: numpar 70 | 71 | namelist/numparticles/numpar ! Number of particles 72 | 73 | 74 | 75 | !*** TIME PARAMETERS *** 76 | 77 | REAL :: days ! Number of days to run the model 78 | INTEGER :: iprint ! Print interval for ROMSPath output (s); 3600 = every hour 79 | INTEGER :: dt ! External time step (duration between hydro model predictions) (s) 80 | INTEGER :: idt ! Internal (particle tracking) time step (s) 81 | ! DOUBLE PRECISION :: dstart ! Start time in data relative to ROMS model initilization 82 | 83 | ! namelist/timeparam/ days,iprint,dt,idt,dstart 84 | namelist/timeparam/ days,iprint,dt,idt 85 | 86 | 87 | !!*** ROMS HYDRODYNAMIC MODULE PARAMETERS *** 88 | LOGICAL :: readZeta ! If .TRUE. read in sea-surface height (zeta) from NetCDF file, else use constZeta 89 | DOUBLE PRECISION :: constZeta ! Constant value for Zeta if readZeta is .FALSE. 90 | LOGICAL :: readSalt ! If .TRUE. read in salinity (salt) from NetCDF file, else use constSalt 91 | DOUBLE PRECISION :: constSalt ! Constant value for Salt if readSalt is .FALSE. 92 | LOGICAL :: readTemp ! If .TRUE. read in temperature (temp) from NetCDF file, else use constTemp 93 | DOUBLE PRECISION :: constTemp ! Constant value for Temp if readTemp is .FALSE. 94 | LOGICAL :: readU ! If .TRUE. read in u-momentum component (U ) from NetCDF file, else use constU 95 | DOUBLE PRECISION :: constU ! Constant value for U if readU is .FALSE. 96 | LOGICAL :: readV ! If .TRUE. read in v-momentum component (V ) from NetCDF file, else use constV 97 | DOUBLE PRECISION :: constV ! Constant value for V if readV is .FALSE. 98 | LOGICAL :: readW ! If .TRUE. read in w-momentum component (W ) from NetCDF file, else use constW 99 | DOUBLE PRECISION :: constW ! Constant value for W if readW is .FALSE. 100 | LOGICAL :: readAks ! If .TRUE. read in salinity vertical diffusion coefficient (Aks ) from NetCDF file, else use constAks 101 | DOUBLE PRECISION :: constAks ! Constant value for Aks if readAks is .FALSE. 102 | LOGICAL :: readDens 103 | DOUBLE PRECISION :: constDens 104 | CHARACTER(LEN=200),Dimension(MAXNgrid) :: stokesprefix 105 | CHARACTER(LEN=200),Dimension(MAXNgrid) :: turbstd_v_a_prefix 106 | CHARACTER(LEN=200),Dimension(MAXNgrid) :: wavestd_prefix 107 | 108 | LOGICAL :: Process_VA ! PROCESS Vort./accel and write to netcdf file. 109 | LOGICAL :: Process_WA ! PROCESS Wave Accel and write to netcdf file. 110 | ! 111 | namelist/hydroparam/readZeta,constZeta,readSalt, & 112 | & constSalt,readTemp,constTemp,readU,readU,constU,readV, & 113 | & constV,readW,constW,readAks,constAks,readDens,constDens, & 114 | & stokesprefix,turbstd_v_a_prefix,wavestd_prefix,Process_VA,Process_WA 115 | 116 | 117 | !*** TURBULENCE MODULE PARAMETERS *** 118 | 119 | LOGICAL :: VTurbOn ! Vertical Turbulence on (.TRUE.) or off (.FALSE.) 120 | DOUBLE PRECISION :: serr !Cubic spline error Cutoff 121 | DOUBLE PRECISION :: smth !Cubic spline smoothing 122 | DOUBLE PRECISION :: sub !Resolution multiplier for cubic spline smoothing 123 | DOUBLE PRECISION :: deltat !Vertical turbulence time step 124 | DOUBLE PRECISION :: AKSback !Vertical turbulence AKS background 125 | LOGICAL :: HTurbOn ! Horizontal Turbulence on (.TRUE.) or off (.FALSE.) 126 | DOUBLE PRECISION :: ConstantHTurb(MAXNgrid) ! Constant value of horizontal turbulence (m2/s) 127 | 128 | namelist/turbparam/VTurbOn,serr,smth,sub,deltat,AKSback,HTurbOn,ConstantHTurb 129 | 130 | !*** Advection MODULE PARAMETERS *** 131 | INTEGER :: scheme !Advection Scheme 132 | INTEGER :: nsb ! Neutral, Surface or bottom 133 | DOUBLE PRECISION :: vertdist ! Vertical distance from surface or bottom for behavior types 1 or 2. 134 | 135 | namelist/advectparam/scheme,nsb,vertdist 136 | !*** BEHAVIOR MODULE PARAMETERS *** 137 | INTEGER :: Behavior ! Behavior type (specify a number) 138 | ! Note: The behavior types numbers are: 139 | ! 0 Passive, 1 near-surface, 2 near-bottom, 140 | ! 141 | LOGICAL :: OpenOceanBoundary ! Note: If you want to allow particles to "escape" via open ocean 142 | ! boundaries, set this to TRUE; Escape means that the particle 143 | ! will stick to the boundary and stop moving 144 | DOUBLE PRECISION :: pediage ! Age when particle reaches max swim speed and can settle (s) 145 | ! Note: for oyster larvae behavior (types 4 & 5): 146 | ! pediage = age at which a particle becomes a pediveliger 147 | ! Note: pediage does not cause particles to settle if the Settlement module is not on 148 | DOUBLE PRECISION :: swimstart ! Age that swimming or sinking begins (s) 1 day = 1.*24.*3600. 149 | DOUBLE PRECISION :: swimslow ! Swimming speed when particle begins to swim (m/s) 150 | DOUBLE PRECISION :: swimfast ! Maximum swimming speed (m/s) 0.05 m/s for 5 mm/s 151 | ! Note: for constant swimming speed for behavior types 1,2 & 3: 152 | ! set swimslow = swimfast = constant speed 153 | DOUBLE PRECISION :: Sgradient ! Salinity gradient threshold that cues larval behavior (psu/m) 154 | ! Note: This parameter is only used if Behavior = 4 or 5. 155 | DOUBLE PRECISION :: sink ! Sinking velocity for behavior type 6 156 | ! Note: This parameter is only used if Behavior = 6. 157 | ! Tidal Stream Transport behavior type: 158 | DOUBLE PRECISION :: Hswimspeed ! Horizontal swimming speed (m/s) 159 | DOUBLE PRECISION :: Swimdepth ! Depth at which fish swims during flood time 160 | ! in meters above bottom (this should be a positive value) 161 | 162 | 163 | namelist/behavparam/Behavior,OpenOceanBoundary,pediage,swimstart,swimslow,swimfast,Sgradient,sink,Hswimspeed,Swimdepth 164 | 165 | 166 | 167 | !*** BEHAVIOR MODULE PARAMETERS , FUCHS PARAMATERIZATION*** 168 | 169 | !%%%%%%%%%%%%%%%%% VORTICITY RESPONSES 170 | DOUBLE PRECISION :: vort_cr !%(s^-1) critical vorticity for inducing response 171 | DOUBLE PRECISION :: vort_sat !%(s^-1) vorticity where response saturates 172 | 173 | DOUBLE PRECISION :: b0pv !% min probability of swimming vs. vorticity 174 | DOUBLE PRECISION :: b1pv !% max probability of swimming vs. vorticity 175 | DOUBLE PRECISION :: b0wv !% (cm s^-1) max swimming velocity vs vorticity -- keep it for flexibility 176 | DOUBLE PRECISION :: b1w !% (cm s^-1) neutral buoyancy (no response) 177 | 178 | !%%%%%%%%%%%%%%%%% ACCELERATION RESPONSES 179 | DOUBLE PRECISION :: acc_cr !%(cm s^-2) critical acceleration for inducing response 180 | DOUBLE PRECISION :: acc_sat !%(cm s^-2) acceleration where response saturates 181 | 182 | DOUBLE PRECISION :: b0pa !% min probability of swimming vs. acceleration 183 | DOUBLE PRECISION :: b1pa !% max probability of swimming vs. acceleration 184 | DOUBLE PRECISION :: b0wa !% (cm s^-1) max swimming velocity vs acceleration 185 | 186 | 187 | INTEGER :: va_flag ! 0=Both, 1=Vorticity Only, 1=Acceleration Only 188 | 189 | namelist/fuchsparam/vort_cr,vort_sat,b0pv,b1pv,b0wv,b1w,acc_cr,acc_sat,b0pa,b1pa,b0wa,va_flag 190 | 191 | !*** Growth MODULE PARAMETERS *** 192 | 193 | INTEGER :: Growth ! Griwth/Age type (specify a number) 194 | ! Note: The aging types numbers are: 195 | ! 0 none, 1 Use deadage, 2 Use Growth, 196 | 197 | LOGICAL :: mortality ! TRUE if particles can die; else FALSE 198 | DOUBLE PRECISION :: deadage ! Age at which a particle stops moving (i.e., dies) (s) 199 | DOUBLE PRECISION :: initsize ! Initial size of Larva(Egg size?) 200 | DOUBLE PRECISION :: maxsize ! Maximum size of larva. (Stop moving after this) 201 | DOUBLE PRECISION :: tempcut ! Temperature cutoff for growth 202 | DOUBLE PRECISION :: a0 ! Growth Coefficient 0 203 | DOUBLE PRECISION :: a1 ! Growth Coefficient 1 204 | DOUBLE PRECISION :: a2 ! Growth Coefficient 2 205 | DOUBLE PRECISION :: a3 ! Growth Coefficient 3 206 | DOUBLE PRECISION :: a4 ! Growth Coefficient 4 207 | DOUBLE PRECISION :: a5 ! Growth Coefficient 5 208 | DOUBLE PRECISION :: a6 ! Growth Coefficient 6 209 | DOUBLE PRECISION :: a7 ! Growth Coefficient 7 210 | DOUBLE PRECISION :: a8 ! Growth Coefficient 8 211 | 212 | 213 | 214 | namelist/growparam/Growth,mortality,deadage,initsize,maxsize,tempcut,a0,a1,a2,a3,a4,a5,a6,a7,a8 215 | 216 | 217 | !*** DVM. The following are parameters for the Diurnal Vertical Migration (DVM) behavior type: 218 | DOUBLE PRECISION :: twistart ! Time of twilight start (hr) ** 219 | DOUBLE PRECISION :: twiend ! Time of twilight end (hr) ** 220 | DOUBLE PRECISION :: daylength ! Length of day (hr) ** 221 | DOUBLE PRECISION :: Em ! Irradiance at solar noon (microE m^-2 s^-1) ** 222 | DOUBLE PRECISION :: Kd ! Vertical attenuation coefficient 223 | DOUBLE PRECISION :: thresh ! Light threshold that cues behavior (microE m^-2 s^-1) 224 | ! Note: These values were calculated for September 1 at the latitude of 37.0 (Chesapeake Bay mouth) 225 | ! Note: Variables marked with ** were calculated with light_v2BlueCrab.f (not included in ROMSPath yet) 226 | ! Note: These parameters are only used if Behavior = 3 227 | 228 | namelist/dvmparam/twistart,twiend,daylength,Em,Kd,thresh 229 | 230 | 231 | 232 | !*** SETTLEMENT MODULE PARAMETERS *** 233 | LOGICAL :: settlementon ! settlement module on (.TRUE.) or off (.FALSE.) 234 | ! Note: If settlement is off: set minholeid, maxholeid, minpolyid, maxpolyid, pedges, & hedges to 1 235 | ! to avoid both wasted variable space and errors due to arrays of size 0. 236 | ! If settlement is on and there are no holes: set minholeid, maxholeid, & hedges to 1 237 | LOGICAL :: holesExist ! Are there holes in habitat? yes(TRUE) no(FALSE) 238 | INTEGER :: minpolyid ! Lowest habitat polygon id number 239 | INTEGER :: maxpolyid ! Highest habitat polygon id number 240 | INTEGER :: minholeid ! Lowest hole id number 241 | INTEGER :: maxholeid ! Highest hole id number 242 | INTEGER :: pedges ! Number of habitat polygon edge points (# of rows in habitat polygon file) 243 | INTEGER :: hedges ! Number of hole edge points (number of rows in holes file) 244 | 245 | namelist/settleparam/settlementon,holesExist,minpolyid,maxpolyid,minholeid,maxholeid,pedges,hedges 246 | 247 | 248 | 249 | 250 | 251 | !*** INPUT FILE NAME AND LOCATION PARAMETERS ***; 252 | 253 | ! ** ROMS NetCDF Model Grid file ** 254 | 255 | INTEGER :: Ngrid ! Number of grids 256 | DOUBLE PRECISION :: refine(MAXNgrid) ! Number of grids 257 | 258 | namelist/romsgrid/Ngrid,refine 259 | 260 | 261 | 262 | ! ** ROMS Predictions NetCDF Input File ** 263 | ! Filename = prefix + filenum + suffix 264 | CHARACTER(LEN=200),Dimension(MAXNgrid) :: prefix ! NetCDF Input Filename prefix 265 | CHARACTER(LEN=200) :: suffix ! NetCDF Input Filename suffix 266 | CHARACTER(LEN=100) :: time_vname ! NetCDF Input Time vairable name (usually ocean_time) 267 | CHARACTER(LEN=100) :: time_dname ! NetCDF Input Time dimension name (usually ocean_time) 268 | INTEGER :: filenum ! Number in First NetCDF Input Filename 269 | INTEGER :: numdigits ! Number of digits in number portion of file name (with leading zeros) 270 | ! LOGICAL :: startfile ! .TRUE. means the first file has an additional time step 271 | LOGICAL :: multifile ! .TRUE. means multiple files are used. .False. means only a single file/url 272 | !Note: the path to the file is necessary if the file is not in the same folder as the code 273 | !Note: if .nc file in separate folder in Windows, then include path in prefix. For example: 274 | ! CHARACTER(LEN=15), PARAMETER :: prefix='D:\ROMS\y95hdr_' 275 | ! if .nc file in separate folder in Linux, then include path in prefix. For example: 276 | ! CHARACTER(LEN=26), PARAMETER :: prefix='/share/lzhong/1995/y95hdr_' 277 | 278 | namelist/romsoutput/prefix,suffix,filenum,numdigits,multifile,time_vname,time_dname 279 | 280 | 281 | 282 | 283 | ! ** Particle Location Input File ** 284 | CHARACTER(LEN=200) :: parfile ! Particle locations file 285 | !Note: the path to the file is necessary if the file is not in the same folder as the code 286 | 287 | namelist/parloc/parfile 288 | 289 | 290 | 291 | ! ** Habitat Polygon Location Input Files ** 292 | CHARACTER(LEN=200) :: habitatfile ! Habitat polygon file 293 | CHARACTER(LEN=200) :: holefile ! Holes in habitat file 294 | !Note: the path to the file is necessary if the file is not in the same folder as the code 295 | 296 | namelist/HabPolyLoc/habitatfile,holefile 297 | 298 | 299 | 300 | ! ** Output Related Variables ** 301 | CHARACTER(LEN=200) :: outpath ! Location to write output files 302 | CHARACTER(LEN=100) :: NCOutFile ! Name of the NetCDF output file if outputting to NetCDF 303 | LOGICAL :: outpathGiven ! If TRUE files are written to the path given in outpath 304 | INTEGER :: NCtime ! Time interval between creation of new NetCDF output files 305 | 306 | !NetCDF Model Metadata: 307 | 308 | CHARACTER(LEN=100) :: RunName ! Unique Identifier for this particular model run 309 | CHARACTER(LEN=200) :: ExeDir ! Location of the model run executable 310 | CHARACTER(LEN=200) :: OutDir ! Location of the model run output files 311 | CHARACTER(LEN=100) :: RunBy ! Name of person who setup/run the model 312 | CHARACTER(LEN=100) :: Institution ! Place the model is run 313 | CHARACTER(LEN=200) :: StartedOn ! Date the model run began 314 | 315 | namelist/output/outpath,NCOutFile,outpathGiven,NCtime, & 316 | RunName,ExeDir,OutDir,RunBy,Institution,StartedOn 317 | 318 | 319 | 320 | !*** OTHER PARAMETERS *** 321 | INTEGER :: seed ! Seed value for random number generator (Mersenne Twister) 322 | INTEGER :: ErrorFlag ! What to do if an error is encountered: 0=stop, 1=return particle to previous location 323 | ! 2=kill particle & stop tracking, 3=set particle out of bounds & stop tracking 324 | ! Note: Options 1-3 will output information to ErrorLog.txt 325 | LOGICAL :: SaltTempOn ! Calculate salinity and temperature at particle 326 | ! location: yes (.TRUE.) or no (.FALSE.) 327 | LOGICAL :: SaltTempMean ! Average Salinity and temperature 328 | DOUBLE PRECISION :: TempOffset ! Temperature offset applied to input 329 | 330 | LOGICAL :: WriteBottom ! Write out bottom stress and height above bottom 331 | LOGICAL :: WriteWaterDepth ! Write Total water depth 332 | LOGICAL :: WriteZeta ! Write zeta 333 | LOGICAL :: WriteBath ! Write ROMS bathymetry(H) 334 | LOGICAL :: TrackCollisions ! Write Bottom and Land Hit Files? .TRUE.=yes, .FALSE.=no 335 | LOGICAL :: WriteHeaders ! Write .txt files with column headers? .TRUE.=yes, .FALSE.=no 336 | LOGICAL :: WriteModelTiming ! Write .csv file with model timing data? .TRUE.=yes, .FALSE.=no 337 | LOGICAL :: WriteProblemFile ! Write a file with problem particles for debugging? .TRUE.=yes, .FALSE.=no 338 | 339 | INTEGER :: ijbuff ! number of extra elements to read in on every side of the particles 340 | 341 | LOGICAL :: FreeSlip ! use free slip condition? 342 | 343 | namelist/other/seed,SaltTempOn,TrackCollisions,WriteHeaders,SaltTempMean,WriteBottom, & 344 | WriteModelTiming,WriteProblemFile,ijbuff,ErrorFlag,FreeSlip,TempOffset,& 345 | WriteWaterDepth,WriteZeta,WriteBath 346 | -------------------------------------------------------------------------------- /grid_module.f90: -------------------------------------------------------------------------------- 1 | MODULE GRID_MOD 2 | 3 | ! Grid MOdule 4 | 5 | ! ROMSPath Version: 1.0.1 6 | 7 | IMPLICIT NONE 8 | PUBLIC 9 | SAVE 10 | 11 | 12 | DOUBLE PRECISION :: reftime 13 | CHARACTER(len=100) :: time_units 14 | TYPE GRIDDATA 15 | DOUBLE PRECISION,pointer :: s_rho(:) 16 | DOUBLE PRECISION,pointer :: s_w(:) 17 | DOUBLE PRECISION,pointer :: cs_r(:) 18 | DOUBLE PRECISION,pointer :: cs_w(:) 19 | DOUBLE PRECISION,pointer :: H(:,:) 20 | DOUBLE PRECISION,pointer :: lon_rho(:,:) 21 | DOUBLE PRECISION,pointer :: lat_rho(:,:) 22 | DOUBLE PRECISION,pointer :: xi(:,:) 23 | DOUBLE PRECISION,pointer :: eta(:,:) 24 | DOUBLE PRECISION,pointer :: pm(:,:) 25 | DOUBLE PRECISION,pointer :: pn(:,:) 26 | DOUBLE PRECISION,pointer :: angle(:,:) 27 | DOUBLE PRECISION,pointer :: scl(:,:) 28 | DOUBLE PRECISION,pointer :: off(:,:) 29 | DOUBLE PRECISION,pointer :: z_rho(:,:,:) 30 | DOUBLE PRECISION,pointer :: z_w(:,:,:) 31 | INTEGER,pointer :: spherical(:) 32 | INTEGER,pointer :: mask_rho(:,:) 33 | INTEGER,pointer :: mask_u(:,:) 34 | INTEGER,pointer :: mask_v(:,:) 35 | END TYPE GRIDDATA 36 | TYPE (GRIDDATA), allocatable :: GRIDS(:) 37 | PUBLIC ::GRIDS 38 | CONTAINS 39 | 40 | 41 | SUBROUTINE InitGrid() 42 | 43 | 44 | USE netcdf 45 | USE PARAM_MOD, ONLY: xi_rho,eta_rho,xi_u,eta_u,xi_v,eta_v, & 46 | s_rho,s_w,Vtransform,Vstretching,theta_s,theta_b,tline,zob, & 47 | prefix,suffix,filenum,numdigits,Ngrid,refine,hc,time_vname 48 | USE HYDRO_MOD, ONLY: getFileNames 49 | IMPLICIT NONE 50 | 51 | ! INTEGER, INTENT(OUT), OPTIONAL :: IOSTAT 52 | 53 | INCLUDE 'netcdf.inc' 54 | 55 | !NetCDF Variables 56 | INTEGER :: NCID,STATUS,VID,dimid,dimcount,ng,ng2,nref,dng 57 | 58 | CHARACTER(len=200) :: filenm,header 59 | CHARACTER(len=100) :: strtmp 60 | DOUBLE PRECISION :: grefine(Ngrid,Ngrid) 61 | !Grid File Output Variables 62 | ! INTEGER :: nR,nU,nV,maxR,maxU,maxV,wetR,wetU,wetV 63 | 64 | !Iteration Variables 65 | INTEGER :: i,j,err,ii,jj 66 | 67 | err = 0 68 | header="PROBLEM READING GRID INFORMATION" 69 | ! *********************** GET GRID INFO *********************** 70 | 71 | ! OPEN NETCDF FILE - GET NCID VALUE 72 | do ng=1,Ngrid 73 | if (ng.eq.1) allocate(GRIDS(Ngrid)) 74 | 75 | call getFileNames(filenm,prefix(ng),filenum) 76 | 77 | 78 | 79 | STATUS = NF90_OPEN(filenm,NF90_NOWRITE,NCID) 80 | if (STATUS .NE. NF90_NOERR) then 81 | write(*,*) 'Problem with NF90_OPEN:' 82 | write(*,*) 'File not found:' 83 | write(*,*) filenm 84 | err = 10 85 | call errorHandler(header,-1) 86 | endif 87 | 88 | ! GET VALUES FOR xi_rho,xi_u,xi_v,eta_rho,eta_u,eta_v 89 | 90 | STATUS = NF90_INQ_DIMID(NCID,'xi_rho',dimid) 91 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 92 | if (STATUS .NE. NF90_NOERR) then 93 | write(*,*) 'Problem dimid xi_rho' 94 | err = 20 95 | call errorHandler(header,-1) 96 | endif 97 | xi_rho(ng) = dimcount 98 | 99 | STATUS = NF90_INQ_DIMID(NCID,'eta_rho',dimid) 100 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 101 | if (STATUS .NE. NF90_NOERR) then 102 | write(*,*) 'Problem dimid eta_rho' 103 | err = 20 104 | call errorHandler(header,-1) 105 | endif 106 | eta_rho(ng) = dimcount 107 | 108 | STATUS = NF90_INQ_DIMID(NCID,'xi_u',dimid) 109 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 110 | if (STATUS .NE. NF90_NOERR) then 111 | write(*,*) 'Problem dimid xi_u' 112 | err = 20 113 | call errorHandler(header,-1) 114 | endif 115 | xi_u(ng) = dimcount 116 | 117 | STATUS = NF90_INQ_DIMID(NCID,'eta_u',dimid) 118 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 119 | if (STATUS .NE. NF90_NOERR) then 120 | write(*,*) 'Problem dimid eta_u' 121 | err = 20 122 | call errorHandler(header,-1) 123 | endif 124 | eta_u(ng) = dimcount 125 | 126 | STATUS = NF90_INQ_DIMID(NCID,'xi_v',dimid) 127 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 128 | if (STATUS .NE. NF90_NOERR) then 129 | write(*,*) 'Problem dimid xi_v' 130 | call errorHandler(header,-1) 131 | err = 20 132 | endif 133 | xi_v(ng) = dimcount 134 | 135 | STATUS = NF90_INQ_DIMID(NCID,'eta_v',dimid) 136 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 137 | if (STATUS .NE. NF90_NOERR) then 138 | write(*,*) 'Problem dimid eta_v' 139 | call errorHandler(header,-1) 140 | err = 20 141 | endif 142 | eta_v(ng) = dimcount 143 | 144 | STATUS = NF90_INQ_DIMID(NCID,'s_rho',dimid) 145 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 146 | if (STATUS .NE. NF90_NOERR) then 147 | write(*,*) 'Problem dimid s_rho' 148 | call errorHandler(header,-1) 149 | err = 20 150 | endif 151 | s_rho(ng) = dimcount 152 | 153 | STATUS = NF90_INQ_DIMID(NCID,'s_w',dimid) 154 | STATUS = NF90_INQUIRE_DIMENSION(NCID,dimid,len=dimcount) 155 | if (STATUS .NE. NF90_NOERR) then 156 | write(*,*) 'Problem dimid s_w' 157 | call errorHandler(header,-1) 158 | err = 20 159 | endif 160 | s_w(ng) = dimcount 161 | 162 | 163 | ! READ IN Grid vertical trasnformation paramters 164 | 165 | STATUS = NF90_INQ_VARID(NCID,'Vtransform',VID) 166 | STATUS = NF90_GET_VAR(NCID,VID,Vtransform(ng)) 167 | if (STATUS .NE. NF90_NOERR) then 168 | write(*,*) 'Problem read Vtransform' 169 | err = 40 170 | call errorHandler(header,-1) 171 | endif 172 | 173 | STATUS = NF90_INQ_VARID(NCID,'Vstretching',VID) 174 | STATUS = NF90_GET_VAR(NCID,VID,Vstretching(ng)) 175 | if (STATUS .NE. NF90_NOERR) then 176 | write(*,*) 'Problem read Vstretching' 177 | err = 40 178 | call errorHandler(header,-1) 179 | endif 180 | 181 | STATUS = NF90_INQ_VARID(NCID,'theta_s',VID) 182 | STATUS = NF90_GET_VAR(NCID,VID,theta_s(ng)) 183 | if (STATUS .NE. NF90_NOERR) then 184 | write(*,*) 'Problem read theta_s' 185 | err = 40 186 | call errorHandler(header,-1) 187 | endif 188 | 189 | STATUS = NF90_INQ_VARID(NCID,'theta_b',VID) 190 | STATUS = NF90_GET_VAR(NCID,VID,theta_b(ng)) 191 | if (STATUS .NE. NF90_NOERR) then 192 | write(*,*) 'Problem read theta_b' 193 | err = 40 194 | call errorHandler(header,-1) 195 | endif 196 | 197 | STATUS = NF90_INQ_VARID(NCID,'hc',VID) 198 | STATUS = NF90_GET_VAR(NCID,VID,hc(ng)) 199 | if (STATUS .NE. NF90_NOERR) then 200 | write(*,*) 'Problem read hc' 201 | err = 40 202 | call errorHandler(header,-1) 203 | endif 204 | 205 | ! ! ALLOCATE VARIABLE ARRAY DIMENSIONS 206 | ALLOCATE(GRIDS(ng)%mask_rho(xi_rho(ng),eta_rho(ng))) 207 | ALLOCATE(GRIDS(ng)%H(xi_rho(ng),eta_rho(ng))) 208 | ALLOCATE(GRIDS(ng)%angle(xi_rho(ng),eta_rho(ng))) 209 | ALLOCATE(GRIDS(ng)%lon_rho(xi_rho(ng),eta_rho(ng))) 210 | ALLOCATE(GRIDS(ng)%lat_rho(xi_rho(ng),eta_rho(ng))) 211 | ALLOCATE(GRIDS(ng)%pm(xi_rho(ng),eta_rho(ng))) 212 | ALLOCATE(GRIDS(ng)%pn(xi_rho(ng),eta_rho(ng))) 213 | ALLOCATE(GRIDS(ng)%mask_u(xi_u(ng),eta_u(ng))) 214 | ALLOCATE(GRIDS(ng)%mask_v(xi_v(ng),eta_v(ng))) 215 | ALLOCATE(GRIDS(ng)%s_rho(s_rho(ng))) 216 | ALLOCATE(GRIDS(ng)%s_w(s_w(ng))) 217 | ALLOCATE(GRIDS(ng)%cs_r(s_rho(ng))) 218 | ALLOCATE(GRIDS(ng)%cs_w(s_w(ng))) 219 | ALLOCATE(GRIDS(ng)%z_w(s_w(ng),Ngrid,3)) 220 | ALLOCATE(GRIDS(ng)%z_rho(s_rho(ng),Ngrid,3)) 221 | ALLOCATE(GRIDS(ng)%xi(xi_rho(ng),eta_rho(ng))) 222 | ALLOCATE(GRIDS(ng)%eta(xi_rho(ng),eta_rho(ng))) 223 | ALLOCATE(GRIDS(ng)%scl(Ngrid,2)) 224 | ALLOCATE(GRIDS(ng)%off(Ngrid,2)) 225 | ALLOCATE(GRIDS(ng)%spherical(1)) 226 | 227 | 228 | 229 | ! READ IN DATA FROM NETCDF FILE TO VARIABLES 230 | ! spherical 231 | STATUS = NF90_INQ_VARID(NCID,'spherical',VID) 232 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%spherical) 233 | if (STATUS .NE. NF90_NOERR) then 234 | write(*,*) 'Problem read spherical' 235 | err = 40 236 | call errorHandler(header,-1) 237 | endif 238 | 239 | 240 | STATUS = NF90_INQ_VARID(NCID,'mask_rho',VID) 241 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%mask_rho) 242 | if (STATUS .NE. NF90_NOERR) then 243 | write(*,*) 'Problem read mask_rho' 244 | err = 40 245 | call errorHandler(header,-1) 246 | endif 247 | 248 | ! u grid mask 249 | STATUS = NF90_INQ_VARID(NCID,'mask_u',VID) 250 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%mask_u) 251 | if(STATUS .NE. NF90_NOERR) then 252 | write(*,*)'Problem read mask_u' 253 | err = 40 254 | call errorHandler(header,-1) 255 | endif 256 | 257 | ! v grid mask 258 | STATUS = NF90_INQ_VARID(NCID,'mask_v',VID) 259 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%mask_v) 260 | if(STATUS .NE. NF90_NOERR) then 261 | write(*,*)'Problem read mask_v' 262 | err = 40 263 | call errorHandler(header,-1) 264 | endif 265 | 266 | SELECT CASE (GRIDS(ng)%spherical(1)) 267 | CASE(0) 268 | write(*,*)'Reading Cartesian' 269 | ! X 270 | STATUS = NF90_INQ_VARID(NCID,'x_rho',VID) 271 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%lon_rho) 272 | if(STATUS .NE. NF90_NOERR) then 273 | write(*,*)'Problem read x_rho' 274 | err = 40 275 | call errorHandler(header,-1) 276 | endif 277 | 278 | ! Y 279 | STATUS = NF90_INQ_VARID(NCID,'y_rho',VID) 280 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%lat_rho) 281 | if(STATUS .NE. NF90_NOERR) then 282 | write(*,*)'Problem read y_rho' 283 | err = 40 284 | call errorHandler(header,-1) 285 | endif 286 | CASE(1) 287 | write(*,*)'Reading Geographic' 288 | ! Longitude 289 | STATUS = NF90_INQ_VARID(NCID,'lon_rho',VID) 290 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%lon_rho) 291 | if(STATUS .NE. NF90_NOERR) then 292 | write(*,*)'Problem read lon_rho' 293 | err = 40 294 | call errorHandler(header,-1) 295 | endif 296 | 297 | ! Latitude 298 | STATUS = NF90_INQ_VARID(NCID,'lat_rho',VID) 299 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%lat_rho) 300 | if(STATUS .NE. NF90_NOERR) then 301 | write(*,*)'Problem read lat_rho' 302 | err = 40 303 | call errorHandler(header,-1) 304 | endif 305 | CASE DEFAULT 306 | PRINT *, "NOT SPHERICAL OR CARTESIAN." 307 | END SELECT 308 | ! H 309 | STATUS = NF90_INQ_VARID(NCID,'h',VID) 310 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%H) 311 | if(STATUS .NE. NF90_NOERR) then 312 | write(*,*)'Problem read H' 313 | err = 40 314 | call errorHandler(header,-1) 315 | endif 316 | ! PM 317 | STATUS = NF90_INQ_VARID(NCID,'pm',VID) 318 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%pm) 319 | if(STATUS .NE. NF90_NOERR) then 320 | write(*,*)'Problem read pm' 321 | err = 40 322 | call errorHandler(header,-1) 323 | endif 324 | ! PN 325 | STATUS = NF90_INQ_VARID(NCID,'pn',VID) 326 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%pn) 327 | if(STATUS .NE. NF90_NOERR) then 328 | write(*,*)'Problem read pn' 329 | err = 40 330 | call errorHandler(header,-1) 331 | endif 332 | ! Angle 333 | STATUS = NF90_INQ_VARID(NCID,'angle',VID) 334 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%angle) 335 | if(STATUS .NE. NF90_NOERR) then 336 | write(*,*)'Problem read pn' 337 | err = 40 338 | call errorHandler(header,-1) 339 | endif 340 | 341 | STATUS = NF90_INQ_VARID(NCID,'s_rho',VID) 342 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%s_rho) 343 | if (STATUS .NE. NF90_NOERR) then 344 | write(*,*) 'Problem read s_rho' 345 | write(*,*) NF90_STRERROR(STATUS) 346 | call errorHandler(header,-1) 347 | endif 348 | 349 | ! Cs value on rho grid (Cs_r) 350 | STATUS = NF90_INQ_VARID(NCID,'Cs_r',VID) 351 | 352 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%cs_r) 353 | if (STATUS .NE. NF90_NOERR) then 354 | write(*,*) 'Problem read CS_r' 355 | write(*,*) NF90_STRERROR(STATUS) 356 | call errorHandler(header,-1) 357 | endif 358 | ! s-coordinate on w grid (sc_w) 359 | STATUS = NF90_INQ_VARID(NCID,'s_w',VID) 360 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%s_w) 361 | if (STATUS .NE. NF90_NOERR) then 362 | write(*,*) 'Problem read s_w' 363 | write(*,*) NF90_STRERROR(STATUS) 364 | call errorHandler(header,-1) 365 | endif 366 | ! Cs value on w grid (Cs_w) 367 | STATUS = NF90_INQ_VARID(NCID,'Cs_w',VID) 368 | STATUS = NF90_GET_VAR(NCID,VID,GRIDS(ng)%cs_w) 369 | if (STATUS .NE. NF90_NOERR) then 370 | write(*,*) 'Problem read cs_w' 371 | write(*,*) NF90_STRERROR(STATUS) 372 | call errorHandler(header,-1) 373 | endif 374 | ! Ocean_time 375 | STATUS = NF90_INQ_VARID(NCID,trim(time_vname),VID) 376 | STATUS = NF90_GET_VAR(NCID,VID,reftime) 377 | if (STATUS .NE. NF90_NOERR) then 378 | write(*,*) 'Problem reading Time variable:' 379 | write(*,*) trim(time_vname) 380 | write(*,*) NF90_STRERROR(STATUS) 381 | call errorHandler(header,-1) 382 | endif 383 | 384 | 385 | 386 | STATUS = nf90_get_att(NCID, VID,'units', strtmp) 387 | if (STATUS .NE. NF90_NOERR) then 388 | write(*,*) 'NO time units' 389 | write(*,*) NF90_STRERROR(STATUS) 390 | call errorHandler(header,-1) 391 | endif 392 | 393 | 394 | if(index(strtmp,'days') .gt. 0)then 395 | reftime=reftime*dble(86400.0) 396 | write(*,*) 'time units in input file are days' 397 | time_units(1:7)='seconds' 398 | time_units(8:100)=strtmp(5:100-3) 399 | elseif(index(strtmp,'hours') .gt. 0)then 400 | write(*,*) 'time units in input file are hours' 401 | reftime=reftime*dble(3600.0) 402 | time_units(1:7)='seconds' 403 | time_units(8:100)=strtmp(6:100-2) 404 | elseif(index(strtmp,'minutes') .gt. 0)then 405 | reftime=reftime*dble(60.0) 406 | write(*,*) 'time units in input file are minutes' 407 | time_units(1:7)='seconds' 408 | time_units(8:100)=strtmp(8:100) 409 | elseif(index(strtmp,'seconds') .gt. 0)then 410 | write(*,*) 'time units in input file are seconds' 411 | time_units=strtmp 412 | else 413 | write(*,*) 'Not a recognized time unit' 414 | call errorHandler(header,-1) 415 | endif 416 | STATUS = NF90_CLOSE(NCID) 417 | if(STATUS /= NF90_NOERR) then 418 | write(*,*)'Problem closing NCID' 419 | err = 50 420 | call errorHandler(header,-1) 421 | endif 422 | 423 | 424 | ! write(*,*) time_units 425 | ! write(*,*) reftime 426 | 427 | ! ********************** MAKE Xi,eta griod ********************** 428 | 429 | do i=1,xi_rho(ng) 430 | do j=1,eta_rho(ng) 431 | GRIDS(ng)%xi(i,j)=i 432 | GRIDS(ng)%eta(i,j)=j 433 | enddo 434 | enddo 435 | 436 | 437 | GRIDS(ng)%scl=1.0d0 438 | GRIDS(ng)%off=0.0d0 439 | grefine=1.0d0 440 | enddo 441 | do ng=1,Ngrid 442 | do ng2=1,Ngrid 443 | dng=abs(ng-ng2) 444 | if (dng.GT.0.0) then 445 | do nref=1,dng 446 | grefine(ng,ng2)=refine(dng)*grefine(ng,ng2) 447 | enddo 448 | endif 449 | enddo 450 | enddo 451 | 452 | !!!!!!!!!!!THIS IS a bit kludgy. 453 | !!!!! setting scales and offsets for coordinate transform. 454 | do ng2=1,Ngrid 455 | do ng=1,Ngrid 456 | loop1:do i=1,xi_rho(ng) 457 | do j=1,eta_rho(ng) 458 | do ii=1,xi_rho(ng2) 459 | do jj=1,eta_rho(ng2) 460 | if ((GRIDS(ng)%lon_rho(i,j).EQ.GRIDS(ng2)%lon_rho(ii,jj)).and. & 461 | (GRIDS(ng)%lat_rho(i,j).EQ.GRIDS(ng2)%lat_rho(ii,jj))) then 462 | 463 | exit loop1 464 | endif 465 | enddo 466 | enddo 467 | enddo 468 | enddo loop1 469 | GRIDS(ng)%scl(ng2,:)=1.0d0/grefine(ng,ng2) 470 | GRIDS(ng2)%scl(ng,:)=grefine(ng2,ng) 471 | 472 | GRIDS(ng)%off(ng2,1)=dble(ii)-GRIDS(ng)%scl(ng2,1)*dble(i) 473 | GRIDS(ng)%off(ng2,2)=dble(jj)-GRIDS(ng)%scl(ng2,2)*dble(j) 474 | GRIDS(ng2)%off(ng,1)=dble(i)-GRIDS(ng2)%scl(ng,1)*dble(ii) 475 | GRIDS(ng2)%off(ng,2)=dble(j)-GRIDS(ng2)%scl(ng,2)*dble(jj) 476 | 477 | 478 | 479 | 480 | enddo 481 | enddo 482 | 483 | ! do ng=1,Ngrid 484 | ! write(*,*) '1--------------' 485 | ! do ng2=1,Ngrid 486 | ! write(*,*) ng,ng2 487 | ! write(*,*) grefine(ng,ng2) 488 | ! write(*,*) GRIDS(ng)%off(ng2,1),GRIDS(ng2)%off(ng,2) 489 | ! write(*,*) GRIDS(ng)%scl(ng2,1),GRIDS(ng2)%scl(ng,2) 490 | 491 | ! enddo 492 | ! enddo 493 | !If IOSTAT is present, set return value to error code 494 | !IF(PRESENT(IOSTAT)) IOSTAT = err 495 | ! 0=No Errors 30=Error allocating arrays 496 | ! 10=Error Opening NCgridfile 40=Error getting variables 497 | ! 20=Error getting dimensions 50=Error Closing NCgridfile 498 | 499 | END SUBROUTINE InitGrid 500 | 501 | SUBROUTINE errorHandler(header, flag) 502 | IMPLICIT NONE 503 | CHARACTER(LEN=120), INTENT(IN) :: header 504 | INTEGER, INTENT(IN) :: flag 505 | 506 | WRITE(*,"(A120)")header !print error message in report.txt 507 | STOP 508 | 509 | 510 | END SUBROUTINE errorHandler 511 | 512 | 513 | DOUBLE PRECISION FUNCTION getSlevel(zeta,depth,ng,i) 514 | !This function returns the depth of the current s-level 515 | USE PARAM_MOD, ONLY: s_rho,s_w,Vtransform,Vstretching,hc 516 | IMPLICIT NONE 517 | INTEGER, INTENT(IN) :: ng,i 518 | DOUBLE PRECISION, INTENT(IN) :: zeta,depth 519 | DOUBLE PRECISION :: h,S 520 | 521 | 522 | ! convert negative depth to positive depth 523 | h = DBLE(-1.0) * depth 524 | 525 | 526 | SELECT CASE(Vtransform(ng)) 527 | 528 | CASE(1) !Rutgers-ROMS formulation, eqn (1) of 529 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 530 | 531 | S = hc(ng)*GRIDS(ng)%s_rho(i)+(h-hc(ng))*GRIDS(ng)%cs_r(i) 532 | getSlevel = S+zeta*(DBLE(1.0)+S/h) 533 | 534 | CASE(2) !UCLA-formulation, eqn(2) of 535 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 536 | 537 | S = (hc(ng)*GRIDS(ng)%s_rho(i)+h*GRIDS(ng)%cs_r(i)) / (hc(ng)+h) 538 | getSlevel = zeta+(zeta+h)*S 539 | 540 | CASE(3) !Song, Y. and D. B. Haidvogel, 1994: A semi-implicit 541 | !ocean circulation model using a generalized topography-following 542 | !coordinate system, J. Comp. Phys., 115 (1), 228-244. 543 | 544 | getSlevel = zeta*(DBLE(1.0)+GRIDS(ng)%s_rho(i))+hc(ng)*GRIDS(ng)%s_rho(i)+(h-hc(ng))*GRIDS(ng)%cs_r(i) 545 | 546 | CASE DEFAULT 547 | write(*,*) 'ERROR: Illegal Vtransform number' 548 | write(*,*) ' ' 549 | write(*,*) 'The Program Cannot Continue and Will Terminate' 550 | stop 551 | 552 | END SELECT 553 | 554 | END FUNCTION getSlevel 555 | 556 | 557 | DOUBLE PRECISION FUNCTION getWlevel(zeta,depth,ng,i) 558 | !This function returns the depth of the current s-level 559 | USE PARAM_MOD, ONLY: s_rho,s_w,Vtransform,Vstretching,hc 560 | IMPLICIT NONE 561 | INTEGER, INTENT(IN) :: ng,i 562 | DOUBLE PRECISION, INTENT(IN) :: zeta,depth 563 | DOUBLE PRECISION :: h,S 564 | 565 | 566 | ! convert negative depth to positive depth 567 | h = DBLE(-1.0) * depth 568 | 569 | 570 | SELECT CASE(Vtransform(ng)) 571 | 572 | CASE(1) !Rutgers-ROMS formulation, eqn (1) of 573 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 574 | 575 | S = hc(ng)*GRIDS(ng)%s_w(i)+(h-hc(ng))*GRIDS(ng)%cs_w(i) 576 | getWlevel = S+zeta*(DBLE(1.0)+S/h) 577 | 578 | CASE(2) !UCLA-formulation, eqn(2) of 579 | !https://www.myroms.org/wiki/index.php/Vertical_S-coordinate 580 | 581 | S = (hc(ng)*GRIDS(ng)%s_w(i)+h*GRIDS(ng)%cs_w(i)) / (hc(ng)+h) 582 | getWlevel = zeta+(zeta+h)*S 583 | 584 | CASE(3) !Song, Y. and D. B. Haidvogel, 1994: A semi-implicit 585 | !ocean circulation model using a generalized topography-following 586 | !coordinate system, J. Comp. Phys., 115 (1), 228-244. 587 | 588 | getWlevel = zeta*(DBLE(1.0)+GRIDS(ng)%s_w(i))+hc(ng)*GRIDS(ng)%s_w(i)+(h-hc(ng))*GRIDS(ng)%cs_w(i) 589 | 590 | CASE DEFAULT 591 | write(*,*) 'ERROR: Illegal Vtransform number' 592 | write(*,*) ' ' 593 | write(*,*) 'The Program Cannot Continue and Will Terminate' 594 | stop 595 | 596 | END SELECT 597 | 598 | END FUNCTION getWlevel 599 | 600 | 601 | END MODULE GRID_MOD 602 | -------------------------------------------------------------------------------- /hydrodynamic_module.f90: -------------------------------------------------------------------------------- 1 | MODULE HYDRO_MOD 2 | 3 | ! This module handles all the input from the hydrodynamic NetCDF input files. 4 | ! It is the only module that interacts with NetCDF input files. It contains 5 | ! all the variables read in from the NetCDF files. It also contains all the 6 | ! information and variables related to the grid elements. 7 | ! 8 | ! Created by: Zachary Schlag 9 | ! Created on: 07 Aug 2008 10 | ! Last Modified on: Feb 2013 11 | ! ROMSPath Version: 1.0.1 12 | 13 | IMPLICIT NONE 14 | PRIVATE 15 | PUBLIC ::getFileNames 16 | 17 | SAVE 18 | 19 | 20 | 21 | !Used for reading in NetCDF variables one time step at a time 22 | INTEGER :: STARTr(4),COUNTr(4),STARTz(3),COUNTz(3) 23 | 24 | !These variables keep track of the interpolation method and weights 25 | ! INTEGER :: tOK 26 | DOUBLE PRECISION :: t,u,Wgt1,Wgt2,Wgt3,Wgt4 27 | ! !The Rho, U, and V nodes that make up the Rho, U, and V element that 28 | ! ! the particle is in 29 | ! INTEGER, ALLOCATABLE,DIMENSION(:) :: rnode1,rnode2,rnode3,rnode4,unode1,unode2,unode3,unode4,vnode1, & 30 | ! vnode2,vnode3,vnode4 31 | 32 | !read in zeta,salinity,temperature,vertical diffusivity, and U,V,W velocities 33 | ! at hydrodynamic back, center, and forward time 34 | 35 | INTEGER, ALLOCATABLE,DIMENSION(:) :: stepf !Keeps track of the forward time step 36 | 37 | 38 | 39 | ! !S-Level location variables 40 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SC,CS,SCW,CSW 41 | ! !Depth at each rho node location 42 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: depth 43 | ! !Rho, U, and V grid wet elements(four node numbers that make up the element) 44 | ! ! (wet means at least 1 node is masked as water) 45 | ! INTEGER, ALLOCATABLE, DIMENSION(:,:) :: RE,UE,VE 46 | ! !Keeps track of the Rho, U, and V element that each particle is in 47 | ! INTEGER, ALLOCATABLE, DIMENSION(:) :: P_r_element,P_u_element,P_v_element 48 | ! !For each element, a list containing itself and all the elements that share a 49 | ! ! node with that element; used to speed up determining which element the 50 | ! ! particle has moved to, if it has moved at all 51 | 52 | 53 | TYPE HDATA 54 | DOUBLE PRECISION,pointer :: zeta(:,:,:) 55 | DOUBLE PRECISION,pointer :: bustr(:,:,:) 56 | DOUBLE PRECISION,pointer :: bvstr(:,:,:) 57 | DOUBLE PRECISION,pointer :: salt(:,:,:,:) 58 | DOUBLE PRECISION,pointer :: temp(:,:,:,:) 59 | DOUBLE PRECISION,pointer :: AKs(:,:,:,:) 60 | DOUBLE PRECISION,pointer :: U(:,:,:,:) 61 | DOUBLE PRECISION,pointer :: V(:,:,:,:) 62 | DOUBLE PRECISION,pointer :: W(:,:,:,:) 63 | DOUBLE PRECISION,pointer :: time(:) 64 | DOUBLE PRECISION,pointer :: Accelstd_t(:,:,:,:) 65 | DOUBLE PRECISION,pointer :: Vortstd_t(:,:,:,:) 66 | DOUBLE PRECISION,pointer :: Accelustd_w(:,:,:,:) 67 | DOUBLE PRECISION,pointer :: Accelvstd_w(:,:,:,:) 68 | DOUBLE PRECISION,pointer :: Accelwstd_w(:,:,:,:) 69 | #ifdef STOKES 70 | DOUBLE PRECISION,pointer :: SU(:,:,:,:) 71 | DOUBLE PRECISION,pointer :: SV(:,:,:,:) 72 | #endif 73 | 74 | #ifdef WETDRY 75 | DOUBLE PRECISION,pointer :: wetdry_mask_u(:,:,:) 76 | DOUBLE PRECISION,pointer :: wetdry_mask_v(:,:,:) 77 | DOUBLE PRECISION,pointer :: wetdry_mask_rho(:,:,:) 78 | #endif 79 | END TYPE HDATA 80 | TYPE (HDATA), allocatable :: HYDRODATA(:) 81 | 82 | 83 | !Keeps track if the grid has been read in yet or not 84 | ! If the grid hasn't been read in, the boundaries can't be made 85 | ! LOGICAL :: GRD_SET = .FALSE. 86 | 87 | !The concatenated hydrodynamic input file name 88 | CHARACTER(len=200) :: filenm,turbfilenm,wavefilenm 89 | #ifdef STOKES 90 | CHARACTER(len=200) :: stokesfilenm 91 | #endif 92 | character(len=256) :: Iname 93 | !Counters for NetCDF files 94 | 95 | 96 | !The following procedures have been made public: 97 | ! PUBLIC :: initGrid,initHydro,updateHydro,setEle,setEle_all,setInterp, & 98 | ! getInterp,interp,WCTS_ITPI,getSlevel,getWlevel,getMask_Rho,getUVxy, & 99 | ! getR_ele,getP_r_element,finHydro,initNetCDF,createNetCDF,writeNetCDF 100 | 101 | PUBLIC :: updateHydro,HYDRODATA 102 | ! & 103 | ! getMask_Rho,getUVxy,finHydro,setEle, & 104 | ! initNetCDF,createNetCDF,writeNetCDF,MODGRID, & 105 | ! getInterp,interp,setInterp,WCTS_ITPI,getSlevel,getWlevel 106 | 107 | CONTAINS 108 | 109 | 110 | 111 | 112 | SUBROUTINE updateHydro(FIRST,tstep,tind) 113 | !This Subroutine reads in the hydrodynamic information for the first 114 | ! iteration 115 | USE PARAM_MOD, ONLY: numpar,xi_rho,eta_rho,s_rho,s_w,suffix,& 116 | prefix,filenum,numdigits,readZeta,constZeta,readSalt,constSalt, & 117 | readTemp,constTemp,readDens,constDens,readU,constU,readV,constV,readW, & 118 | constW,readAks,constAks,Ngrid,xi_u,eta_u,xi_v,eta_v,tdim,t_b,t_c,t_f,& 119 | stokesprefix,TempOffset,WriteBottom,turbstd_v_a_prefix,wavestd_prefix,& 120 | Behavior,Process_VA,Process_WA,time_vname,time_dname 121 | USE netcdf 122 | IMPLICIT NONE 123 | 124 | INCLUDE 'netcdf.inc' 125 | 126 | INTEGER :: STATUS,NCID,VID,DIMID,dimcount 127 | LOGICAL,INTENT(IN) :: FIRST 128 | 129 | INTEGER ,INTENT(IN) :: tstep,tind 130 | INTEGER :: i,j,k,ng 131 | real :: before,after,tdiff 132 | 133 | 134 | 135 | do ng=1,Ngrid 136 | if (FIRST) then 137 | if (ng.eq.1) allocate(HYDRODATA(Ngrid)) 138 | !ALLOCATE MODULE VARIABLES 139 | ALLOCATE(HYDRODATA(ng)%zeta(xi_rho(ng),eta_rho(ng),3)) 140 | ALLOCATE(HYDRODATA(ng)%bustr(xi_u(ng),eta_u(ng),3)) 141 | ALLOCATE(HYDRODATA(ng)%bvstr(xi_v(ng),eta_v(ng),3)) 142 | ALLOCATE(HYDRODATA(ng)%salt(xi_rho(ng),eta_rho(ng),s_rho(ng),3)) 143 | ALLOCATE(HYDRODATA(ng)%temp(xi_rho(ng),eta_rho(ng),s_rho(ng),3)) 144 | ALLOCATE(HYDRODATA(ng)%W(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 145 | ALLOCATE(HYDRODATA(ng)%AKs(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 146 | ALLOCATE(HYDRODATA(ng)%U(xi_u(ng),eta_u(ng),s_rho(ng),3)) 147 | ALLOCATE(HYDRODATA(ng)%V(xi_v(ng),eta_v(ng),s_rho(ng),3)) 148 | ALLOCATE(HYDRODATA(ng)%AKs(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 149 | ALLOCATE(HYDRODATA(ng)%Accelstd_t(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 150 | ALLOCATE(HYDRODATA(ng)%Vortstd_t(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 151 | ALLOCATE(HYDRODATA(ng)%Accelustd_w(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 152 | ALLOCATE(HYDRODATA(ng)%Accelvstd_w(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 153 | ALLOCATE(HYDRODATA(ng)%Accelwstd_w(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 154 | #ifdef STOKES 155 | ALLOCATE(HYDRODATA(ng)%SU(xi_u(ng),eta_u(ng),s_rho(ng),3)) 156 | ALLOCATE(HYDRODATA(ng)%SV(xi_v(ng),eta_v(ng),s_rho(ng),3)) 157 | #endif 158 | #ifdef WETDRY 159 | ALLOCATE(HYDRODATA(ng)%wetdry_mask_u(xi_u(ng),eta_u(ng),3)) 160 | ALLOCATE(HYDRODATA(ng)%wetdry_mask_v(xi_v(ng),eta_v(ng),3)) 161 | ALLOCATE(HYDRODATA(ng)%wetdry_mask_rho(xi_rho(ng),eta_rho(ng),3)) 162 | HYDRODATA(ng)%wetdry_mask_u = 0 163 | HYDRODATA(ng)%wetdry_mask_v = 0 164 | HYDRODATA(ng)%wetdry_mask_rho = 0 165 | #endif 166 | HYDRODATA(ng)%zeta = 0 167 | HYDRODATA(ng)%salt = 0 168 | HYDRODATA(ng)%temp = 0 169 | HYDRODATA(ng)%AKs = 0 170 | HYDRODATA(ng)%U = 0 171 | HYDRODATA(ng)%V = 0 172 | HYDRODATA(ng)%W = 0 173 | HYDRODATA(ng)%Accelstd_t = 0 174 | HYDRODATA(ng)%Vortstd_t = 0 175 | HYDRODATA(ng)%Accelustd_w = 0 176 | HYDRODATA(ng)%Accelvstd_w = 0 177 | HYDRODATA(ng)%Accelwstd_w = 0 178 | 179 | 180 | 181 | endif 182 | 183 | 184 | ! !Open netCDF file 185 | call getFileNames(filenm,prefix(ng),filenum) 186 | call getFileNames(turbfilenm,turbstd_v_a_prefix(ng),filenum) 187 | call getFileNames(wavefilenm,wavestd_prefix(ng),filenum) 188 | #ifdef STOKES 189 | call getFileNames(stokesfilenm,stokesprefix(ng),filenum) 190 | #endif 191 | 192 | 193 | if (tstep.eq.1)then 194 | write(*,*) "New ROMS File:" 195 | write(*,*) filenm 196 | endif 197 | 198 | 199 | 200 | ! Read in data for first three external time steps 201 | 202 | STATUS = NF90_OPEN(TRIM(filenm), NF90_NOWRITE, NCID) 203 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN HYDROFILE' 204 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 205 | 206 | 207 | 208 | 209 | STATUS = NF90_INQ_DIMID(NCID,trim(time_dname),DIMID) 210 | STATUS = NF90_INQUIRE_DIMENSION(NCID,DIMID,len=dimcount) 211 | if (STATUS .NE. NF90_NOERR) then 212 | write(*,*) 'Problem with dimid:' 213 | write(*,*) time_dname 214 | write(*,*) NF90_STRERROR(STATUS) 215 | endif 216 | tdim(ng) = dimcount 217 | 218 | startz(1)=tstep 219 | countz(1)=1 220 | STATUS = NF90_INQ_VARID(NCID,trim(time_vname),VID) 221 | if (STATUS .NE. NF90_NOERR) then 222 | write(*,*) 'Problem finding time variable:' 223 | write(*,*) trim(time_vname) 224 | write(*,*) NF90_STRERROR(STATUS) 225 | stop 226 | endif 227 | ! STATUS = NF90_GET_VAR(NCID,VID,ttime,startz,countz) 228 | 229 | 230 | 231 | 232 | if(readZeta)then 233 | ! **** Zeta **** 234 | startz(1)=1 235 | startz(2)=1 236 | startz(3)=tstep 237 | 238 | countz(1)=xi_rho(ng) 239 | countz(2)=eta_rho(ng) 240 | countz(3)=1 241 | 242 | STATUS = NF90_INQ_VARID(NCID,'zeta',VID) 243 | if (STATUS .NE. NF90_NOERR) then 244 | write(*,*) 'Problem find zeta' 245 | write(*,*) NF90_STRERROR(STATUS) 246 | stop 247 | endif 248 | 249 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%zeta(:,:,tind),STARTz,COUNTz) 250 | if (STATUS .NE. NF90_NOERR) then 251 | write(*,*) 'Problem read zeta array 1' 252 | write(*,*) NF90_STRERROR(STATUS) 253 | stop 254 | endif 255 | else 256 | HYDRODATA(ng)%zeta= constZeta 257 | endif 258 | 259 | if(readSalt)then 260 | ! **** Salt **** 261 | startr(1)=1 262 | startr(2)=1 263 | startr(3)=1 264 | startr(4)=tstep 265 | 266 | countr(1)=xi_rho(ng) 267 | countr(2)=eta_rho(ng) 268 | countr(3)=s_rho(ng) 269 | countr(4)=1 270 | STATUS = NF90_INQ_VARID(NCID,'salt',VID) 271 | if (STATUS .NE. NF90_NOERR) then 272 | write(*,*) 'Problem find salt' 273 | write(*,*) NF90_STRERROR(STATUS) 274 | stop 275 | endif 276 | 277 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%salt(:,:,:,tind),STARTr,COUNTr) 278 | if (STATUS .NE. NF90_NOERR) then 279 | write(*,*) 'Problem read salt array' 280 | write(*,*) NF90_STRERROR(STATUS) 281 | stop 282 | endif 283 | else 284 | HYDRODATA(ng)%salt = constSalt 285 | endif 286 | 287 | if(readTemp)then 288 | ! **** Temp **** 289 | startr(1)=1 290 | startr(2)=1 291 | startr(3)=1 292 | startr(4)=tstep 293 | 294 | countr(1)=xi_rho(ng) 295 | countr(2)=eta_rho(ng) 296 | countr(3)=s_rho(ng) 297 | countr(4)=1 298 | STATUS = NF90_INQ_VARID(NCID,'temp',VID) 299 | if (STATUS .NE. NF90_NOERR) then 300 | write(*,*) 'Problem find temp' 301 | write(*,*) NF90_STRERROR(STATUS) 302 | stop 303 | endif 304 | 305 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%temp(:,:,:,tind),STARTr,COUNTr) 306 | if (STATUS .NE. NF90_NOERR) then 307 | write(*,*) 'Problem read temp array' 308 | write(*,*) NF90_STRERROR(STATUS) 309 | stop 310 | endif 311 | 312 | do i=1,xi_rho(ng) 313 | do j=1,eta_rho(ng) 314 | do k=1,s_rho(ng) 315 | HYDRODATA(ng)%temp(i,j,k,tind)=HYDRODATA(ng)%temp(i,j,k,tind)+TempOffset 316 | enddo 317 | enddo 318 | enddo 319 | else 320 | HYDRODATA(ng)%temp = constTemp 321 | endif 322 | 323 | 324 | 325 | 326 | ! call CPU_TIME(before) 327 | if(readU)then 328 | ! **** U velocity **** 329 | startr(1)=1 330 | startr(2)=1 331 | startr(3)=1 332 | startr(4)=tstep 333 | 334 | countr(1)=xi_u(ng) 335 | countr(2)=eta_u(ng) 336 | countr(3)=s_rho(ng) 337 | countr(4)=1 338 | 339 | 340 | 341 | 342 | STATUS = NF90_INQ_VARID(NCID,'u',VID) 343 | if (STATUS .NE. NF90_NOERR) then 344 | write(*,*) 'Problem find u' 345 | write(*,*) NF90_STRERROR(STATUS) 346 | stop 347 | endif 348 | 349 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%U(:,:,:,tind),STARTr,COUNTr) 350 | if (STATUS .NE. NF90_NOERR) then 351 | write(*,*) 'Problem read u array' 352 | write(*,*) NF90_STRERROR(STATUS) 353 | stop 354 | endif 355 | 356 | 357 | else 358 | HYDRODATA(ng)%U = constU 359 | endif 360 | 361 | 362 | 363 | 364 | 365 | if(readV)then 366 | ! **** V velocity **** 367 | startr(1)=1 368 | startr(2)=1 369 | startr(3)=1 370 | startr(4)=tstep 371 | 372 | countr(1)=xi_v(ng) 373 | countr(2)=eta_v(ng) 374 | countr(3)=s_rho(ng) 375 | countr(4)=1 376 | 377 | STATUS = NF90_INQ_VARID(NCID,'v',VID) 378 | if (STATUS .NE. NF90_NOERR) then 379 | write(*,*) 'Problem find v' 380 | write(*,*) NF90_STRERROR(STATUS) 381 | stop 382 | endif 383 | 384 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%V(:,:,:,tind),STARTr,COUNTr) 385 | if (STATUS .NE. NF90_NOERR) then 386 | write(*,*) 'Problem read v array' 387 | write(*,*) NF90_STRERROR(STATUS) 388 | stop 389 | endif 390 | 391 | 392 | else 393 | HYDRODATA(ng)%V = constV 394 | endif 395 | 396 | ! call CPU_TIME(after) 397 | ! tdiff=after-before 398 | ! write(*,*) '****' 399 | ! write(*,*) tdiff 400 | 401 | if(WriteBottom)then 402 | ! **** U stress **** 403 | startr(1)=1 404 | startr(2)=1 405 | startr(3)=tstep 406 | 407 | countr(1)=xi_u(ng) 408 | countr(2)=eta_u(ng) 409 | countr(3)=1 410 | STATUS = NF90_INQ_VARID(NCID,'bustr',VID) 411 | if (STATUS .NE. NF90_NOERR) then 412 | write(*,*) 'Problem find bustr' 413 | write(*,*) NF90_STRERROR(STATUS) 414 | stop 415 | endif 416 | 417 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%bustr(:,:,tind),STARTr,COUNTr) 418 | if (STATUS .NE. NF90_NOERR) then 419 | write(*,*) 'Problem read bustr array' 420 | write(*,*) NF90_STRERROR(STATUS) 421 | stop 422 | endif 423 | 424 | ! **** v stress **** 425 | startr(1)=1 426 | startr(2)=1 427 | startr(3)=tstep 428 | 429 | countr(1)=xi_v(ng) 430 | countr(2)=eta_v(ng) 431 | countr(3)=1 432 | STATUS = NF90_INQ_VARID(NCID,'bvstr',VID) 433 | if (STATUS .NE. NF90_NOERR) then 434 | write(*,*) 'Problem find bvstr' 435 | write(*,*) NF90_STRERROR(STATUS) 436 | stop 437 | endif 438 | 439 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%bvstr(:,:,tind),STARTr,COUNTr) 440 | if (STATUS .NE. NF90_NOERR) then 441 | write(*,*) 'Problem read bvstr array' 442 | write(*,*) NF90_STRERROR(STATUS) 443 | stop 444 | endif 445 | 446 | 447 | 448 | else 449 | HYDRODATA(ng)%bustr = 0.0 450 | HYDRODATA(ng)%bvstr = 0.0 451 | endif 452 | 453 | 454 | if(readW)then 455 | ! **** W velocity **** 456 | startr(1)=1 457 | startr(2)=1 458 | startr(3)=1 459 | startr(4)=tstep 460 | 461 | countr(1)=xi_rho(ng) 462 | countr(2)=eta_rho(ng) 463 | countr(3)=s_w(ng) 464 | countr(4)=1 465 | STATUS = NF90_INQ_VARID(NCID,'w',VID) 466 | if (STATUS .NE. NF90_NOERR) then 467 | write(*,*) 'Problem find w' 468 | write(*,*) NF90_STRERROR(STATUS) 469 | stop 470 | endif 471 | 472 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%W(:,:,:,tind),STARTr,COUNTr) 473 | if (STATUS .NE. NF90_NOERR) then 474 | write(*,*) 'Problem read w array' 475 | write(*,*) NF90_STRERROR(STATUS) 476 | stop 477 | endif 478 | else 479 | HYDRODATA(ng)%W = constW 480 | endif 481 | 482 | if(readAks)then 483 | ! **** Vertical diffusivity for salt (Aks) **** 484 | startr(1)=1 485 | startr(2)=1 486 | startr(3)=1 487 | startr(4)=tstep 488 | 489 | countr(1)=xi_rho(ng) 490 | countr(2)=eta_rho(ng) 491 | countr(3)=s_w(ng) 492 | countr(4)=1 493 | STATUS = NF90_INQ_VARID(NCID,'AKs',VID) 494 | if (STATUS .NE. NF90_NOERR) then 495 | write(*,*) 'Problem find AKs' 496 | write(*,*) NF90_STRERROR(STATUS) 497 | stop 498 | endif 499 | 500 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%AKs(:,:,:,tind),STARTr,COUNTr) 501 | if (STATUS .NE. NF90_NOERR) then 502 | write(*,*) 'Problem read AKs array' 503 | write(*,*) NF90_STRERROR(STATUS) 504 | stop 505 | endif 506 | else 507 | HYDRODATA(ng)%AKs = constAks 508 | endif 509 | 510 | #ifdef WETDRY 511 | 512 | startz(1)=1 513 | startz(2)=1 514 | startz(3)=tstep 515 | 516 | countz(1)=xi_v(ng) 517 | countz(2)=eta_v(ng) 518 | countz(3)=1 519 | STATUS = NF90_INQ_VARID(NCID,'wetdry_mask_v',VID) 520 | if (STATUS .NE. NF90_NOERR) then 521 | write(*,*) 'Problem find wetdry_mask_v' 522 | write(*,*) NF90_STRERROR(STATUS) 523 | stop 524 | endif 525 | 526 | 527 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%wetdry_mask_v(:,:,tind),STARTz,COUNTz) 528 | if (STATUS .NE. NF90_NOERR) then 529 | write(*,*) 'Problem read wetdry_mask_v array' 530 | write(*,*) NF90_STRERROR(STATUS) 531 | stop 532 | endif 533 | 534 | countz(1)=xi_u(ng) 535 | countz(2)=eta_u(ng) 536 | countz(3)=1 537 | STATUS = NF90_INQ_VARID(NCID,'wetdry_mask_u',VID) 538 | if (STATUS .NE. NF90_NOERR) then 539 | write(*,*) 'Problem find wetdry_mask_u' 540 | write(*,*) NF90_STRERROR(STATUS) 541 | stop 542 | endif 543 | 544 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%wetdry_mask_u(:,:,tind),STARTz,COUNTz) 545 | if (STATUS .NE. NF90_NOERR) then 546 | write(*,*) 'Problem read wetdry_mask_u array' 547 | write(*,*) NF90_STRERROR(STATUS) 548 | stop 549 | endif 550 | 551 | 552 | countz(1)=xi_rho(ng) 553 | countz(2)=eta_rho(ng) 554 | countz(3)=1 555 | STATUS = NF90_INQ_VARID(NCID,'wetdry_mask_rho',VID) 556 | if (STATUS .NE. NF90_NOERR) then 557 | write(*,*) 'Problem find wetdry_mask_rho' 558 | write(*,*) NF90_STRERROR(STATUS) 559 | stop 560 | endif 561 | 562 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%wetdry_mask_rho(:,:,tind),STARTz,COUNTz) 563 | if (STATUS .NE. NF90_NOERR) then 564 | write(*,*) 'Problem read wetdry_mask_rho array' 565 | write(*,*) NF90_STRERROR(STATUS) 566 | stop 567 | endif 568 | 569 | 570 | #endif 571 | ! !close the dataset and reassign the NCID 572 | STATUS = NF90_CLOSE(NCID) 573 | #ifdef STOKES 574 | 575 | ! call CPU_TIME(before) 576 | STATUS = NF90_OPEN(TRIM(stokesfilenm), NF90_NOWRITE, NCID) 577 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN STOKESFILE' 578 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 579 | 580 | 581 | 582 | ! **** STOKES U velocity **** 583 | startr(1)=1 584 | startr(2)=1 585 | startr(3)=1 586 | startr(4)=tstep 587 | 588 | countr(1)=xi_u(ng) 589 | countr(2)=eta_u(ng) 590 | countr(3)=s_rho(ng) 591 | countr(4)=1 592 | 593 | 594 | STATUS = NF90_INQ_VARID(NCID,'ustokes',VID) 595 | if (STATUS .NE. NF90_NOERR) then 596 | write(*,*) 'Problem find u' 597 | write(*,*) NF90_STRERROR(STATUS) 598 | stop 599 | endif 600 | 601 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%SU(:,:,:,tind),STARTr,COUNTr) 602 | if (STATUS .NE. NF90_NOERR) then 603 | write(*,*) 'Problem read stokes u array' 604 | write(*,*) NF90_STRERROR(STATUS) 605 | stop 606 | endif 607 | 608 | do i=1,xi_u(ng) 609 | do j=1,eta_u(ng) 610 | do k=1,s_rho(ng) 611 | HYDRODATA(ng)%U(i,j,k,tind)=HYDRODATA(ng)%U(i,j,k,tind)+HYDRODATA(ng)%SU(i,j,k,tind) 612 | enddo 613 | enddo 614 | enddo 615 | 616 | 617 | ! **** STOKES V velocity **** 618 | startr(1)=1 619 | startr(2)=1 620 | startr(3)=1 621 | startr(4)=tstep 622 | 623 | countr(1)=xi_v(ng) 624 | countr(2)=eta_v(ng) 625 | countr(3)=s_rho(ng) 626 | countr(4)=1 627 | 628 | STATUS = NF90_INQ_VARID(NCID,'vstokes',VID) 629 | if (STATUS .NE. NF90_NOERR) then 630 | write(*,*) 'Problem find v' 631 | write(*,*) NF90_STRERROR(STATUS) 632 | stop 633 | endif 634 | 635 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%SV(:,:,:,tind),STARTr,COUNTr) 636 | if (STATUS .NE. NF90_NOERR) then 637 | write(*,*) 'Problem read stokes v array' 638 | write(*,*) NF90_STRERROR(STATUS) 639 | stop 640 | endif 641 | 642 | 643 | 644 | 645 | STATUS = NF90_CLOSE(NCID) 646 | ! call CPU_TIME(after) 647 | ! tdiff=after-before 648 | ! write(*,*) '^^^' 649 | ! write(*,*) tdiff 650 | 651 | do i=1,xi_v(ng) 652 | do j=1,eta_v(ng) 653 | do k=1,s_rho(ng) 654 | HYDRODATA(ng)%V(i,j,k,tind)=HYDRODATA(ng)%V(i,j,k,tind)+HYDRODATA(ng)%SV(i,j,k,tind) 655 | enddo 656 | enddo 657 | enddo 658 | 659 | 660 | #endif 661 | 662 | if ((Behavior.EQ.10) .OR. (Process_VA)) then 663 | ! call CPU_TIME(before) 664 | 665 | startr(1)=1 666 | startr(2)=1 667 | startr(3)=1 668 | startr(4)=tstep 669 | 670 | countr(1)=xi_rho(ng) 671 | countr(2)=eta_rho(ng) 672 | countr(3)=s_w(ng) 673 | countr(4)=1 674 | 675 | STATUS = NF90_OPEN(TRIM(turbfilenm), NF90_NOWRITE, NCID) 676 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN turbfilenm' 677 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 678 | 679 | 680 | 681 | STATUS = NF90_INQ_VARID(NCID,'vortstd_cmpnt_turb',VID) 682 | if (STATUS .NE. NF90_NOERR) then 683 | write(*,*) 'Problem find vortstd_cmpnt_turb' 684 | write(*,*) NF90_STRERROR(STATUS) 685 | stop 686 | endif 687 | 688 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Vortstd_t(:,:,:,tind),STARTr,COUNTr) 689 | if (STATUS .NE. NF90_NOERR) then 690 | write(*,*) 'Problem read vortstd_cmpnt_turb array' 691 | write(*,*) NF90_STRERROR(STATUS) 692 | stop 693 | endif 694 | 695 | 696 | 697 | STATUS = NF90_INQ_VARID(NCID,'accelstd_cmpnt_turb',VID) 698 | if (STATUS .NE. NF90_NOERR) then 699 | write(*,*) 'Problem find accelstd_cmpnt_turb' 700 | write(*,*) NF90_STRERROR(STATUS) 701 | stop 702 | endif 703 | 704 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Accelstd_t(:,:,:,tind),STARTr,COUNTr) 705 | if (STATUS .NE. NF90_NOERR) then 706 | write(*,*) 'Problem read accelstd_cmpnt_turb array' 707 | write(*,*) NF90_STRERROR(STATUS) 708 | stop 709 | endif 710 | 711 | STATUS = NF90_CLOSE(NCID) 712 | 713 | endif 714 | 715 | 716 | 717 | if (Process_WA) then 718 | 719 | STATUS = NF90_OPEN(TRIM(wavefilenm), NF90_NOWRITE, NCID) 720 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN wavefilenm' 721 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 722 | 723 | STATUS = NF90_INQ_VARID(NCID,'accelstd_u_wave',VID) 724 | if (STATUS .NE. NF90_NOERR) then 725 | write(*,*) 'Problem find accelstd_u_wave' 726 | write(*,*) NF90_STRERROR(STATUS) 727 | stop 728 | endif 729 | 730 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Accelustd_w(:,:,:,tind),STARTr,COUNTr) 731 | if (STATUS .NE. NF90_NOERR) then 732 | write(*,*) 'Problem read accelstd_u_waves array' 733 | write(*,*) NF90_STRERROR(STATUS) 734 | stop 735 | endif 736 | 737 | 738 | STATUS = NF90_INQ_VARID(NCID,'accelstd_v_wave',VID) 739 | if (STATUS .NE. NF90_NOERR) then 740 | write(*,*) 'Problem find accelstd_v_wave' 741 | write(*,*) NF90_STRERROR(STATUS) 742 | stop 743 | endif 744 | 745 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Accelvstd_w(:,:,:,tind),STARTr,COUNTr) 746 | if (STATUS .NE. NF90_NOERR) then 747 | write(*,*) 'Problem read accelstd_u_waves array' 748 | write(*,*) NF90_STRERROR(STATUS) 749 | stop 750 | endif 751 | 752 | STATUS = NF90_CLOSE(NCID) 753 | endif 754 | 755 | 756 | 757 | enddo 758 | 759 | 760 | END SUBROUTINE updateHydro 761 | 762 | 763 | 764 | 765 | SUBROUTINE finHydro() 766 | !This subroutine closes all the module's allocatable variables 767 | IMPLICIT NONE 768 | 769 | 770 | DEALLOCATE(HYDRODATA) 771 | 772 | END SUBROUTINE finHydro 773 | 774 | SUBROUTINE getFileNames(filenm,prefix,filenum) 775 | USE PARAM_MOD, ONLY: numdigits,suffix,multifile 776 | IMPLICIT NONE 777 | INTEGER, INTENT(IN) :: filenum 778 | CHARACTER(len=200), INTENT(INOUT) :: filenm,prefix 779 | 780 | if (multifile) then 781 | SELECT CASE(numdigits) 782 | CASE(1) 783 | WRITE(filenm,'(A,I1.1,A)') TRIM(prefix),filenum,TRIM(suffix) 784 | CASE(2) 785 | WRITE(filenm,'(A,I2.2,A)') TRIM(prefix),filenum,TRIM(suffix) 786 | CASE(3) 787 | WRITE(filenm,'(A,I3.3,A)') TRIM(prefix),filenum,TRIM(suffix) 788 | CASE(4) 789 | WRITE(filenm,'(A,I4.4,A)') TRIM(prefix),filenum,TRIM(suffix) 790 | CASE(5) 791 | WRITE(filenm,'(A,I5.5,A)') TRIM(prefix),filenum,TRIM(suffix) 792 | CASE(6) 793 | WRITE(filenm,'(A,I6.6,A)') TRIM(prefix),filenum,TRIM(suffix) 794 | CASE(7) 795 | WRITE(filenm,'(A,I7.7,A)') TRIM(prefix),filenum,TRIM(suffix) 796 | CASE(8) 797 | WRITE(filenm,'(A,I8.8,A)') TRIM(prefix),filenum,TRIM(suffix) 798 | CASE DEFAULT 799 | WRITE(*,*) 'Model presently does not support numdigits of ',numdigits 800 | WRITE(*,*) 'Please use numdigit value from 1 to 8' 801 | WRITE(*,*) ' OR modify code in Hydrodynamic module' 802 | STOP 803 | END SELECT 804 | else 805 | filenm=TRIM(prefix) 806 | endif 807 | 808 | END SUBROUTINE 809 | 810 | END MODULE HYDRO_MOD 811 | -------------------------------------------------------------------------------- /CROCO/hydrodynamic_module.f90: -------------------------------------------------------------------------------- 1 | MODULE HYDRO_MOD 2 | 3 | ! This module handles all the input from the hydrodynamic NetCDF input files. 4 | ! It is the only module that interacts with NetCDF input files. It contains 5 | ! all the variables read in from the NetCDF files. It also contains all the 6 | ! information and variables related to the grid elements. 7 | ! 8 | ! Created by: Zachary Schlag 9 | ! Created on: 07 Aug 2008 10 | ! Last Modified on: Feb 2013 11 | ! ROMSPath Version: 1.0.1 12 | 13 | IMPLICIT NONE 14 | PRIVATE 15 | PUBLIC ::getFileNames 16 | 17 | SAVE 18 | 19 | 20 | 21 | !Used for reading in NetCDF variables one time step at a time 22 | INTEGER :: STARTr(4),COUNTr(4),STARTz(3),COUNTz(3) 23 | 24 | !These variables keep track of the interpolation method and weights 25 | ! INTEGER :: tOK 26 | DOUBLE PRECISION :: t,u,Wgt1,Wgt2,Wgt3,Wgt4 27 | ! !The Rho, U, and V nodes that make up the Rho, U, and V element that 28 | ! ! the particle is in 29 | ! INTEGER, ALLOCATABLE,DIMENSION(:) :: rnode1,rnode2,rnode3,rnode4,unode1,unode2,unode3,unode4,vnode1, & 30 | ! vnode2,vnode3,vnode4 31 | 32 | !read in zeta,salinity,temperature,vertical diffusivity, and U,V,W velocities 33 | ! at hydrodynamic back, center, and forward time 34 | 35 | INTEGER, ALLOCATABLE,DIMENSION(:) :: stepf !Keeps track of the forward time step 36 | 37 | 38 | 39 | ! !S-Level location variables 40 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: SC,CS,SCW,CSW 41 | ! !Depth at each rho node location 42 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: depth 43 | ! !Rho, U, and V grid wet elements(four node numbers that make up the element) 44 | ! ! (wet means at least 1 node is masked as water) 45 | ! INTEGER, ALLOCATABLE, DIMENSION(:,:) :: RE,UE,VE 46 | ! !Keeps track of the Rho, U, and V element that each particle is in 47 | ! INTEGER, ALLOCATABLE, DIMENSION(:) :: P_r_element,P_u_element,P_v_element 48 | ! !For each element, a list containing itself and all the elements that share a 49 | ! ! node with that element; used to speed up determining which element the 50 | ! ! particle has moved to, if it has moved at all 51 | 52 | 53 | TYPE HDATA 54 | DOUBLE PRECISION,pointer :: zeta(:,:,:) 55 | DOUBLE PRECISION,pointer :: bustr(:,:,:) 56 | DOUBLE PRECISION,pointer :: bvstr(:,:,:) 57 | DOUBLE PRECISION,pointer :: salt(:,:,:,:) 58 | DOUBLE PRECISION,pointer :: temp(:,:,:,:) 59 | DOUBLE PRECISION,pointer :: AKs(:,:,:,:) 60 | DOUBLE PRECISION,pointer :: U(:,:,:,:) 61 | DOUBLE PRECISION,pointer :: V(:,:,:,:) 62 | DOUBLE PRECISION,pointer :: W(:,:,:,:) 63 | DOUBLE PRECISION,pointer :: time(:) 64 | DOUBLE PRECISION,pointer :: Accelstd_t(:,:,:,:) 65 | DOUBLE PRECISION,pointer :: Vortstd_t(:,:,:,:) 66 | DOUBLE PRECISION,pointer :: Accelustd_w(:,:,:,:) 67 | DOUBLE PRECISION,pointer :: Accelvstd_w(:,:,:,:) 68 | DOUBLE PRECISION,pointer :: Accelwstd_w(:,:,:,:) 69 | #ifdef STOKES 70 | DOUBLE PRECISION,pointer :: SU(:,:,:,:) 71 | DOUBLE PRECISION,pointer :: SV(:,:,:,:) 72 | #endif 73 | 74 | #ifdef WETDRY 75 | DOUBLE PRECISION,pointer :: wetdry_mask_u(:,:,:) 76 | DOUBLE PRECISION,pointer :: wetdry_mask_v(:,:,:) 77 | DOUBLE PRECISION,pointer :: wetdry_mask_rho(:,:,:) 78 | #endif 79 | END TYPE HDATA 80 | TYPE (HDATA), allocatable :: HYDRODATA(:) 81 | 82 | 83 | !Keeps track if the grid has been read in yet or not 84 | ! If the grid hasn't been read in, the boundaries can't be made 85 | ! LOGICAL :: GRD_SET = .FALSE. 86 | 87 | !The concatenated hydrodynamic input file name 88 | CHARACTER(len=200) :: filenm,turbfilenm,wavefilenm 89 | #ifdef STOKES 90 | CHARACTER(len=200) :: stokesfilenm 91 | #endif 92 | character(len=256) :: Iname 93 | !Counters for NetCDF files 94 | 95 | 96 | !The following procedures have been made public: 97 | ! PUBLIC :: initGrid,initHydro,updateHydro,setEle,setEle_all,setInterp, & 98 | ! getInterp,interp,WCTS_ITPI,getSlevel,getWlevel,getMask_Rho,getUVxy, & 99 | ! getR_ele,getP_r_element,finHydro,initNetCDF,createNetCDF,writeNetCDF 100 | 101 | PUBLIC :: updateHydro,HYDRODATA 102 | ! & 103 | ! getMask_Rho,getUVxy,finHydro,setEle, & 104 | ! initNetCDF,createNetCDF,writeNetCDF,MODGRID, & 105 | ! getInterp,interp,setInterp,WCTS_ITPI,getSlevel,getWlevel 106 | 107 | CONTAINS 108 | 109 | 110 | 111 | 112 | SUBROUTINE updateHydro(FIRST,tstep,tind) 113 | !This Subroutine reads in the hydrodynamic information for the first 114 | ! iteration 115 | USE PARAM_MOD, ONLY: numpar,xi_rho,eta_rho,s_rho,s_w,suffix,& 116 | prefix,filenum,numdigits,readZeta,constZeta,readSalt,constSalt, & 117 | readTemp,constTemp,readDens,constDens,readU,constU,readV,constV,readW, & 118 | constW,readAks,constAks,Ngrid,xi_u,eta_u,xi_v,eta_v,tdim,t_b,t_c,t_f,& 119 | stokesprefix,TempOffset,WriteBottom,turbstd_v_a_prefix,wavestd_prefix,& 120 | Behavior,Process_VA,Process_WA,time_vname,time_dname 121 | USE netcdf 122 | IMPLICIT NONE 123 | 124 | INCLUDE 'netcdf.inc' 125 | 126 | INTEGER :: STATUS,NCID,VID,DIMID,dimcount 127 | LOGICAL,INTENT(IN) :: FIRST 128 | 129 | INTEGER ,INTENT(IN) :: tstep,tind 130 | INTEGER :: i,j,k,ng 131 | real :: before,after,tdiff 132 | 133 | 134 | 135 | do ng=1,Ngrid 136 | if (FIRST) then 137 | if (ng.eq.1) allocate(HYDRODATA(Ngrid)) 138 | !ALLOCATE MODULE VARIABLES 139 | ALLOCATE(HYDRODATA(ng)%zeta(xi_rho(ng),eta_rho(ng),3)) 140 | ALLOCATE(HYDRODATA(ng)%bustr(xi_u(ng),eta_u(ng),3)) 141 | ALLOCATE(HYDRODATA(ng)%bvstr(xi_v(ng),eta_v(ng),3)) 142 | ALLOCATE(HYDRODATA(ng)%salt(xi_rho(ng),eta_rho(ng),s_rho(ng),3)) 143 | ALLOCATE(HYDRODATA(ng)%temp(xi_rho(ng),eta_rho(ng),s_rho(ng),3)) 144 | ALLOCATE(HYDRODATA(ng)%W(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 145 | ALLOCATE(HYDRODATA(ng)%AKs(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 146 | ALLOCATE(HYDRODATA(ng)%U(xi_u(ng),eta_u(ng),s_rho(ng),3)) 147 | ALLOCATE(HYDRODATA(ng)%V(xi_v(ng),eta_v(ng),s_rho(ng),3)) 148 | ALLOCATE(HYDRODATA(ng)%AKs(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 149 | ALLOCATE(HYDRODATA(ng)%Accelstd_t(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 150 | ALLOCATE(HYDRODATA(ng)%Vortstd_t(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 151 | ALLOCATE(HYDRODATA(ng)%Accelustd_w(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 152 | ALLOCATE(HYDRODATA(ng)%Accelvstd_w(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 153 | ALLOCATE(HYDRODATA(ng)%Accelwstd_w(xi_rho(ng),eta_rho(ng),s_w(ng),3)) 154 | #ifdef STOKES 155 | ALLOCATE(HYDRODATA(ng)%SU(xi_u(ng),eta_u(ng),s_rho(ng),3)) 156 | ALLOCATE(HYDRODATA(ng)%SV(xi_v(ng),eta_v(ng),s_rho(ng),3)) 157 | #endif 158 | #ifdef WETDRY 159 | ALLOCATE(HYDRODATA(ng)%wetdry_mask_u(xi_u(ng),eta_u(ng),3)) 160 | ALLOCATE(HYDRODATA(ng)%wetdry_mask_v(xi_v(ng),eta_v(ng),3)) 161 | ALLOCATE(HYDRODATA(ng)%wetdry_mask_rho(xi_rho(ng),eta_rho(ng),3)) 162 | HYDRODATA(ng)%wetdry_mask_u = 0 163 | HYDRODATA(ng)%wetdry_mask_v = 0 164 | HYDRODATA(ng)%wetdry_mask_rho = 0 165 | #endif 166 | HYDRODATA(ng)%zeta = 0 167 | HYDRODATA(ng)%salt = 0 168 | HYDRODATA(ng)%temp = 0 169 | HYDRODATA(ng)%AKs = 0 170 | HYDRODATA(ng)%U = 0 171 | HYDRODATA(ng)%V = 0 172 | HYDRODATA(ng)%W = 0 173 | HYDRODATA(ng)%Accelstd_t = 0 174 | HYDRODATA(ng)%Vortstd_t = 0 175 | HYDRODATA(ng)%Accelustd_w = 0 176 | HYDRODATA(ng)%Accelvstd_w = 0 177 | HYDRODATA(ng)%Accelwstd_w = 0 178 | 179 | 180 | 181 | endif 182 | 183 | 184 | ! !Open netCDF file 185 | call getFileNames(filenm,prefix(ng),filenum) 186 | call getFileNames(turbfilenm,turbstd_v_a_prefix(ng),filenum) 187 | call getFileNames(wavefilenm,wavestd_prefix(ng),filenum) 188 | #ifdef STOKES 189 | call getFileNames(stokesfilenm,stokesprefix(ng),filenum) 190 | #endif 191 | 192 | 193 | if (tstep.eq.1)then 194 | write(*,*) "New ROMS File:" 195 | write(*,*) filenm 196 | endif 197 | 198 | 199 | 200 | ! Read in data for first three external time steps 201 | 202 | STATUS = NF90_OPEN(TRIM(filenm), NF90_NOWRITE, NCID) 203 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN HYDROFILE' 204 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 205 | 206 | 207 | 208 | 209 | STATUS = NF90_INQ_DIMID(NCID,trim(time_dname),DIMID) 210 | STATUS = NF90_INQUIRE_DIMENSION(NCID,DIMID,len=dimcount) 211 | if (STATUS .NE. NF90_NOERR) then 212 | write(*,*) 'Problem with dimid:' 213 | write(*,*) time_dname 214 | write(*,*) NF90_STRERROR(STATUS) 215 | endif 216 | tdim(ng) = dimcount 217 | 218 | startz(1)=tstep 219 | countz(1)=1 220 | STATUS = NF90_INQ_VARID(NCID,trim(time_vname),VID) 221 | if (STATUS .NE. NF90_NOERR) then 222 | write(*,*) 'Problem finding time variable:' 223 | write(*,*) trim(time_vname) 224 | write(*,*) NF90_STRERROR(STATUS) 225 | stop 226 | endif 227 | ! STATUS = NF90_GET_VAR(NCID,VID,ttime,startz,countz) 228 | 229 | 230 | 231 | 232 | if(readZeta)then 233 | ! **** Zeta **** 234 | startz(1)=1 235 | startz(2)=1 236 | startz(3)=tstep 237 | 238 | countz(1)=xi_rho(ng) 239 | countz(2)=eta_rho(ng) 240 | countz(3)=1 241 | 242 | STATUS = NF90_INQ_VARID(NCID,'zeta',VID) 243 | if (STATUS .NE. NF90_NOERR) then 244 | write(*,*) 'Problem find zeta' 245 | write(*,*) NF90_STRERROR(STATUS) 246 | stop 247 | endif 248 | 249 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%zeta(:,:,tind),STARTz,COUNTz) 250 | if (STATUS .NE. NF90_NOERR) then 251 | write(*,*) 'Problem read zeta array 1' 252 | write(*,*) NF90_STRERROR(STATUS) 253 | stop 254 | endif 255 | else 256 | HYDRODATA(ng)%zeta= constZeta 257 | endif 258 | 259 | if(readSalt)then 260 | ! **** Salt **** 261 | startr(1)=1 262 | startr(2)=1 263 | startr(3)=1 264 | startr(4)=tstep 265 | 266 | countr(1)=xi_rho(ng) 267 | countr(2)=eta_rho(ng) 268 | countr(3)=s_rho(ng) 269 | countr(4)=1 270 | STATUS = NF90_INQ_VARID(NCID,'salt',VID) 271 | if (STATUS .NE. NF90_NOERR) then 272 | write(*,*) 'Problem find salt' 273 | write(*,*) NF90_STRERROR(STATUS) 274 | stop 275 | endif 276 | 277 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%salt(:,:,:,tind),STARTr,COUNTr) 278 | if (STATUS .NE. NF90_NOERR) then 279 | write(*,*) 'Problem read salt array' 280 | write(*,*) NF90_STRERROR(STATUS) 281 | stop 282 | endif 283 | else 284 | HYDRODATA(ng)%salt = constSalt 285 | endif 286 | 287 | if(readTemp)then 288 | ! **** Temp **** 289 | startr(1)=1 290 | startr(2)=1 291 | startr(3)=1 292 | startr(4)=tstep 293 | 294 | countr(1)=xi_rho(ng) 295 | countr(2)=eta_rho(ng) 296 | countr(3)=s_rho(ng) 297 | countr(4)=1 298 | STATUS = NF90_INQ_VARID(NCID,'temp',VID) 299 | if (STATUS .NE. NF90_NOERR) then 300 | write(*,*) 'Problem find temp' 301 | write(*,*) NF90_STRERROR(STATUS) 302 | stop 303 | endif 304 | 305 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%temp(:,:,:,tind),STARTr,COUNTr) 306 | if (STATUS .NE. NF90_NOERR) then 307 | write(*,*) 'Problem read temp array' 308 | write(*,*) NF90_STRERROR(STATUS) 309 | stop 310 | endif 311 | 312 | do i=1,xi_rho(ng) 313 | do j=1,eta_rho(ng) 314 | do k=1,s_rho(ng) 315 | HYDRODATA(ng)%temp(i,j,k,tind)=HYDRODATA(ng)%temp(i,j,k,tind)+TempOffset 316 | enddo 317 | enddo 318 | enddo 319 | else 320 | HYDRODATA(ng)%temp = constTemp 321 | endif 322 | 323 | 324 | 325 | 326 | ! call CPU_TIME(before) 327 | if(readU)then 328 | ! **** U velocity **** 329 | startr(1)=1 330 | startr(2)=1 331 | startr(3)=1 332 | startr(4)=tstep 333 | 334 | countr(1)=xi_u(ng) 335 | countr(2)=eta_u(ng) 336 | countr(3)=s_rho(ng) 337 | countr(4)=1 338 | 339 | 340 | 341 | 342 | STATUS = NF90_INQ_VARID(NCID,'u',VID) 343 | if (STATUS .NE. NF90_NOERR) then 344 | write(*,*) 'Problem find u' 345 | write(*,*) NF90_STRERROR(STATUS) 346 | stop 347 | endif 348 | 349 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%U(:,:,:,tind),STARTr,COUNTr) 350 | if (STATUS .NE. NF90_NOERR) then 351 | write(*,*) 'Problem read u array' 352 | write(*,*) NF90_STRERROR(STATUS) 353 | stop 354 | endif 355 | 356 | 357 | else 358 | HYDRODATA(ng)%U = constU 359 | endif 360 | 361 | 362 | 363 | 364 | 365 | if(readV)then 366 | ! **** V velocity **** 367 | startr(1)=1 368 | startr(2)=1 369 | startr(3)=1 370 | startr(4)=tstep 371 | 372 | countr(1)=xi_v(ng) 373 | countr(2)=eta_v(ng) 374 | countr(3)=s_rho(ng) 375 | countr(4)=1 376 | 377 | STATUS = NF90_INQ_VARID(NCID,'v',VID) 378 | if (STATUS .NE. NF90_NOERR) then 379 | write(*,*) 'Problem find v' 380 | write(*,*) NF90_STRERROR(STATUS) 381 | stop 382 | endif 383 | 384 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%V(:,:,:,tind),STARTr,COUNTr) 385 | if (STATUS .NE. NF90_NOERR) then 386 | write(*,*) 'Problem read v array' 387 | write(*,*) NF90_STRERROR(STATUS) 388 | stop 389 | endif 390 | 391 | 392 | else 393 | HYDRODATA(ng)%V = constV 394 | endif 395 | 396 | ! call CPU_TIME(after) 397 | ! tdiff=after-before 398 | ! write(*,*) '****' 399 | ! write(*,*) tdiff 400 | 401 | if(WriteBottom)then 402 | ! **** U stress **** 403 | startr(1)=1 404 | startr(2)=1 405 | startr(3)=tstep 406 | 407 | countr(1)=xi_u(ng) 408 | countr(2)=eta_u(ng) 409 | countr(3)=1 410 | STATUS = NF90_INQ_VARID(NCID,'bustr',VID) 411 | if (STATUS .NE. NF90_NOERR) then 412 | write(*,*) 'Problem find bustr' 413 | write(*,*) NF90_STRERROR(STATUS) 414 | stop 415 | endif 416 | 417 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%bustr(:,:,tind),STARTr,COUNTr) 418 | if (STATUS .NE. NF90_NOERR) then 419 | write(*,*) 'Problem read bustr array' 420 | write(*,*) NF90_STRERROR(STATUS) 421 | stop 422 | endif 423 | 424 | ! **** v stress **** 425 | startr(1)=1 426 | startr(2)=1 427 | startr(3)=tstep 428 | 429 | countr(1)=xi_v(ng) 430 | countr(2)=eta_v(ng) 431 | countr(3)=1 432 | STATUS = NF90_INQ_VARID(NCID,'bvstr',VID) 433 | if (STATUS .NE. NF90_NOERR) then 434 | write(*,*) 'Problem find bvstr' 435 | write(*,*) NF90_STRERROR(STATUS) 436 | stop 437 | endif 438 | 439 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%bvstr(:,:,tind),STARTr,COUNTr) 440 | if (STATUS .NE. NF90_NOERR) then 441 | write(*,*) 'Problem read bvstr array' 442 | write(*,*) NF90_STRERROR(STATUS) 443 | stop 444 | endif 445 | 446 | 447 | 448 | else 449 | HYDRODATA(ng)%bustr = 0.0 450 | HYDRODATA(ng)%bvstr = 0.0 451 | endif 452 | 453 | 454 | if(readW)then 455 | ! **** W velocity **** 456 | startr(1)=1 457 | startr(2)=1 458 | startr(3)=1 459 | startr(4)=tstep 460 | 461 | countr(1)=xi_rho(ng) 462 | countr(2)=eta_rho(ng) 463 | !countr(3)=s_w(ng) 464 | countr(3)=s_rho(ng) !ELI 465 | countr(4)=1 466 | STATUS = NF90_INQ_VARID(NCID,'w',VID) 467 | if (STATUS .NE. NF90_NOERR) then 468 | write(*,*) 'Problem find w' 469 | write(*,*) NF90_STRERROR(STATUS) 470 | stop 471 | endif 472 | 473 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%W(:,:,:,tind),STARTr,COUNTr) 474 | if (STATUS .NE. NF90_NOERR) then 475 | write(*,*) 'Problem read w array' 476 | write(*,*) NF90_STRERROR(STATUS) 477 | stop 478 | endif 479 | else 480 | HYDRODATA(ng)%W = constW 481 | endif 482 | 483 | if(readAks)then 484 | ! **** Vertical diffusivity for salt (Aks) **** 485 | startr(1)=1 486 | startr(2)=1 487 | startr(3)=1 488 | startr(4)=tstep 489 | 490 | countr(1)=xi_rho(ng) 491 | countr(2)=eta_rho(ng) 492 | countr(3)=s_w(ng) 493 | countr(4)=1 494 | STATUS = NF90_INQ_VARID(NCID,'AKs',VID) 495 | if (STATUS .NE. NF90_NOERR) then 496 | write(*,*) 'Problem find AKs' 497 | write(*,*) NF90_STRERROR(STATUS) 498 | stop 499 | endif 500 | 501 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%AKs(:,:,:,tind),STARTr,COUNTr) 502 | if (STATUS .NE. NF90_NOERR) then 503 | write(*,*) 'Problem read AKs array' 504 | write(*,*) NF90_STRERROR(STATUS) 505 | stop 506 | endif 507 | else 508 | HYDRODATA(ng)%AKs = constAks 509 | endif 510 | 511 | #ifdef WETDRY 512 | 513 | startz(1)=1 514 | startz(2)=1 515 | startz(3)=tstep 516 | 517 | countz(1)=xi_v(ng) 518 | countz(2)=eta_v(ng) 519 | countz(3)=1 520 | STATUS = NF90_INQ_VARID(NCID,'wetdry_mask_v',VID) 521 | if (STATUS .NE. NF90_NOERR) then 522 | write(*,*) 'Problem find wetdry_mask_v' 523 | write(*,*) NF90_STRERROR(STATUS) 524 | stop 525 | endif 526 | 527 | 528 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%wetdry_mask_v(:,:,tind),STARTz,COUNTz) 529 | if (STATUS .NE. NF90_NOERR) then 530 | write(*,*) 'Problem read wetdry_mask_v array' 531 | write(*,*) NF90_STRERROR(STATUS) 532 | stop 533 | endif 534 | 535 | countz(1)=xi_u(ng) 536 | countz(2)=eta_u(ng) 537 | countz(3)=1 538 | STATUS = NF90_INQ_VARID(NCID,'wetdry_mask_u',VID) 539 | if (STATUS .NE. NF90_NOERR) then 540 | write(*,*) 'Problem find wetdry_mask_u' 541 | write(*,*) NF90_STRERROR(STATUS) 542 | stop 543 | endif 544 | 545 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%wetdry_mask_u(:,:,tind),STARTz,COUNTz) 546 | if (STATUS .NE. NF90_NOERR) then 547 | write(*,*) 'Problem read wetdry_mask_u array' 548 | write(*,*) NF90_STRERROR(STATUS) 549 | stop 550 | endif 551 | 552 | 553 | countz(1)=xi_rho(ng) 554 | countz(2)=eta_rho(ng) 555 | countz(3)=1 556 | STATUS = NF90_INQ_VARID(NCID,'wetdry_mask_rho',VID) 557 | if (STATUS .NE. NF90_NOERR) then 558 | write(*,*) 'Problem find wetdry_mask_rho' 559 | write(*,*) NF90_STRERROR(STATUS) 560 | stop 561 | endif 562 | 563 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%wetdry_mask_rho(:,:,tind),STARTz,COUNTz) 564 | if (STATUS .NE. NF90_NOERR) then 565 | write(*,*) 'Problem read wetdry_mask_rho array' 566 | write(*,*) NF90_STRERROR(STATUS) 567 | stop 568 | endif 569 | 570 | 571 | #endif 572 | ! !close the dataset and reassign the NCID 573 | STATUS = NF90_CLOSE(NCID) 574 | #ifdef STOKES 575 | 576 | ! call CPU_TIME(before) 577 | STATUS = NF90_OPEN(TRIM(stokesfilenm), NF90_NOWRITE, NCID) 578 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN STOKESFILE' 579 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 580 | 581 | 582 | 583 | ! **** STOKES U velocity **** 584 | startr(1)=1 585 | startr(2)=1 586 | startr(3)=1 587 | startr(4)=tstep 588 | 589 | countr(1)=xi_u(ng) 590 | countr(2)=eta_u(ng) 591 | countr(3)=s_rho(ng) 592 | countr(4)=1 593 | 594 | 595 | STATUS = NF90_INQ_VARID(NCID,'ustokes',VID) 596 | if (STATUS .NE. NF90_NOERR) then 597 | write(*,*) 'Problem find u' 598 | write(*,*) NF90_STRERROR(STATUS) 599 | stop 600 | endif 601 | 602 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%SU(:,:,:,tind),STARTr,COUNTr) 603 | if (STATUS .NE. NF90_NOERR) then 604 | write(*,*) 'Problem read stokes u array' 605 | write(*,*) NF90_STRERROR(STATUS) 606 | stop 607 | endif 608 | 609 | do i=1,xi_u(ng) 610 | do j=1,eta_u(ng) 611 | do k=1,s_rho(ng) 612 | HYDRODATA(ng)%U(i,j,k,tind)=HYDRODATA(ng)%U(i,j,k,tind)+HYDRODATA(ng)%SU(i,j,k,tind) 613 | enddo 614 | enddo 615 | enddo 616 | 617 | 618 | ! **** STOKES V velocity **** 619 | startr(1)=1 620 | startr(2)=1 621 | startr(3)=1 622 | startr(4)=tstep 623 | 624 | countr(1)=xi_v(ng) 625 | countr(2)=eta_v(ng) 626 | countr(3)=s_rho(ng) 627 | countr(4)=1 628 | 629 | STATUS = NF90_INQ_VARID(NCID,'vstokes',VID) 630 | if (STATUS .NE. NF90_NOERR) then 631 | write(*,*) 'Problem find v' 632 | write(*,*) NF90_STRERROR(STATUS) 633 | stop 634 | endif 635 | 636 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%SV(:,:,:,tind),STARTr,COUNTr) 637 | if (STATUS .NE. NF90_NOERR) then 638 | write(*,*) 'Problem read stokes v array' 639 | write(*,*) NF90_STRERROR(STATUS) 640 | stop 641 | endif 642 | 643 | 644 | 645 | 646 | STATUS = NF90_CLOSE(NCID) 647 | ! call CPU_TIME(after) 648 | ! tdiff=after-before 649 | ! write(*,*) '^^^' 650 | ! write(*,*) tdiff 651 | 652 | do i=1,xi_v(ng) 653 | do j=1,eta_v(ng) 654 | do k=1,s_rho(ng) 655 | HYDRODATA(ng)%V(i,j,k,tind)=HYDRODATA(ng)%V(i,j,k,tind)+HYDRODATA(ng)%SV(i,j,k,tind) 656 | enddo 657 | enddo 658 | enddo 659 | 660 | 661 | #endif 662 | 663 | if ((Behavior.EQ.10) .OR. (Process_VA)) then 664 | ! call CPU_TIME(before) 665 | 666 | startr(1)=1 667 | startr(2)=1 668 | startr(3)=1 669 | startr(4)=tstep 670 | 671 | countr(1)=xi_rho(ng) 672 | countr(2)=eta_rho(ng) 673 | countr(3)=s_w(ng) 674 | countr(4)=1 675 | 676 | STATUS = NF90_OPEN(TRIM(turbfilenm), NF90_NOWRITE, NCID) 677 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN turbfilenm' 678 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 679 | 680 | 681 | 682 | STATUS = NF90_INQ_VARID(NCID,'vortstd_cmpnt_turb',VID) 683 | if (STATUS .NE. NF90_NOERR) then 684 | write(*,*) 'Problem find vortstd_cmpnt_turb' 685 | write(*,*) NF90_STRERROR(STATUS) 686 | stop 687 | endif 688 | 689 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Vortstd_t(:,:,:,tind),STARTr,COUNTr) 690 | if (STATUS .NE. NF90_NOERR) then 691 | write(*,*) 'Problem read vortstd_cmpnt_turb array' 692 | write(*,*) NF90_STRERROR(STATUS) 693 | stop 694 | endif 695 | 696 | 697 | 698 | STATUS = NF90_INQ_VARID(NCID,'accelstd_cmpnt_turb',VID) 699 | if (STATUS .NE. NF90_NOERR) then 700 | write(*,*) 'Problem find accelstd_cmpnt_turb' 701 | write(*,*) NF90_STRERROR(STATUS) 702 | stop 703 | endif 704 | 705 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Accelstd_t(:,:,:,tind),STARTr,COUNTr) 706 | if (STATUS .NE. NF90_NOERR) then 707 | write(*,*) 'Problem read accelstd_cmpnt_turb array' 708 | write(*,*) NF90_STRERROR(STATUS) 709 | stop 710 | endif 711 | 712 | STATUS = NF90_CLOSE(NCID) 713 | 714 | endif 715 | 716 | 717 | 718 | if (Process_WA) then 719 | 720 | STATUS = NF90_OPEN(TRIM(wavefilenm), NF90_NOWRITE, NCID) 721 | if (STATUS .NE. NF90_NOERR) write(*,*) 'Problem NF90_OPEN wavefilenm' 722 | if (STATUS .NE. NF90_NOERR) write(*,*) NF90_STRERROR(STATUS) 723 | 724 | STATUS = NF90_INQ_VARID(NCID,'accelstd_u_wave',VID) 725 | if (STATUS .NE. NF90_NOERR) then 726 | write(*,*) 'Problem find accelstd_u_wave' 727 | write(*,*) NF90_STRERROR(STATUS) 728 | stop 729 | endif 730 | 731 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Accelustd_w(:,:,:,tind),STARTr,COUNTr) 732 | if (STATUS .NE. NF90_NOERR) then 733 | write(*,*) 'Problem read accelstd_u_waves array' 734 | write(*,*) NF90_STRERROR(STATUS) 735 | stop 736 | endif 737 | 738 | 739 | STATUS = NF90_INQ_VARID(NCID,'accelstd_v_wave',VID) 740 | if (STATUS .NE. NF90_NOERR) then 741 | write(*,*) 'Problem find accelstd_v_wave' 742 | write(*,*) NF90_STRERROR(STATUS) 743 | stop 744 | endif 745 | 746 | STATUS = NF90_GET_VAR(NCID,VID,HYDRODATA(ng)%Accelvstd_w(:,:,:,tind),STARTr,COUNTr) 747 | if (STATUS .NE. NF90_NOERR) then 748 | write(*,*) 'Problem read accelstd_u_waves array' 749 | write(*,*) NF90_STRERROR(STATUS) 750 | stop 751 | endif 752 | 753 | STATUS = NF90_CLOSE(NCID) 754 | endif 755 | 756 | 757 | 758 | enddo 759 | 760 | 761 | END SUBROUTINE updateHydro 762 | 763 | 764 | 765 | 766 | SUBROUTINE finHydro() 767 | !This subroutine closes all the module's allocatable variables 768 | IMPLICIT NONE 769 | 770 | 771 | DEALLOCATE(HYDRODATA) 772 | 773 | END SUBROUTINE finHydro 774 | 775 | SUBROUTINE getFileNames(filenm,prefix,filenum) 776 | USE PARAM_MOD, ONLY: numdigits,suffix,multifile 777 | IMPLICIT NONE 778 | INTEGER, INTENT(IN) :: filenum 779 | CHARACTER(len=200), INTENT(INOUT) :: filenm,prefix 780 | 781 | if (multifile) then 782 | SELECT CASE(numdigits) 783 | CASE(1) 784 | WRITE(filenm,'(A,I1.1,A)') TRIM(prefix),filenum,TRIM(suffix) 785 | CASE(2) 786 | WRITE(filenm,'(A,I2.2,A)') TRIM(prefix),filenum,TRIM(suffix) 787 | CASE(3) 788 | WRITE(filenm,'(A,I3.3,A)') TRIM(prefix),filenum,TRIM(suffix) 789 | CASE(4) 790 | WRITE(filenm,'(A,I4.4,A)') TRIM(prefix),filenum,TRIM(suffix) 791 | CASE(5) 792 | WRITE(filenm,'(A,I5.5,A)') TRIM(prefix),filenum,TRIM(suffix) 793 | CASE(6) 794 | WRITE(filenm,'(A,I6.6,A)') TRIM(prefix),filenum,TRIM(suffix) 795 | CASE(7) 796 | WRITE(filenm,'(A,I7.7,A)') TRIM(prefix),filenum,TRIM(suffix) 797 | CASE(8) 798 | WRITE(filenm,'(A,I8.8,A)') TRIM(prefix),filenum,TRIM(suffix) 799 | CASE DEFAULT 800 | WRITE(*,*) 'Model presently does not support numdigits of ',numdigits 801 | WRITE(*,*) 'Please use numdigit value from 1 to 8' 802 | WRITE(*,*) ' OR modify code in Hydrodynamic module' 803 | STOP 804 | END SELECT 805 | else 806 | filenm=TRIM(prefix) 807 | endif 808 | 809 | END SUBROUTINE 810 | 811 | END MODULE HYDRO_MOD 812 | -------------------------------------------------------------------------------- /behavior_module.f90: -------------------------------------------------------------------------------- 1 | MODULE BEHAVIOR_MOD 2 | 3 | ! The behavior module is used to assign biological or physical characteristics 4 | ! to particles. 5 | ! Currently particle movement is in the vertical direction. 6 | ! 7 | ! Particle characteristics can include a swimming/sinking speed component and 8 | ! a behavioral cue component that can depend upon particle age. The swimming/ 9 | ! sinking speed component controls the speed of particle motion and can be 10 | ! constant or set with a function. The behavioral cue component regulates the 11 | ! direction of particle movement. For biological behaviors, a random component 12 | ! is added to the swimming speed and direction to simulate random variation in 13 | ! the movements of individuals (in behavior types 1 - 5, see list below). 14 | ! Physical characteristics can also be assigned to particles, like constant 15 | ! sinking velocity, without the additional random movements (behavior type 6). 16 | ! The following behavior types are currently available in ROMSPath and are 17 | ! specified using the Behavior parameter in the ROMSPath.inc file: 18 | ! 19 | ! 20 | ! Passive (no behavior): Behavior = 0. In this case, the behavior module is not 21 | ! executed. Particle motion is based on advection, and, if turned on, 22 | ! horizontal and vertical turbulence. 23 | ! 24 | ! Near-surface orientation: Behavior = 1. Particles swim up if they are deeper 25 | ! than 1 m from the surface. 26 | ! 27 | ! Near-bottom orientation: Behavior = 2. Particles swim down if they are 28 | ! shallower than 1 m from the bottom. 29 | ! 30 | ! Diurnal vertical migration: Behavior = 3. Particles swim down if light levels 31 | ! at the particle location exceed a predefined threshold value. 32 | ! 33 | ! Crassostrea virginica oyster larvae: Behavior = 4. Swimming speeds and 34 | ! direction of motion vary depending upon age (stage) according to field and 35 | ! laboratory observations (see North et al. 2008). 36 | ! 37 | ! C. ariakensis oyster larvae: Behavior = 5. Swimming speeds and direction of 38 | ! motion vary depending upon age (stage) according to field and laboratory 39 | ! observations (see North et al. 2008). 40 | ! 41 | ! Sinking velocity: Behavior = 6. Particles move up or down with constant 42 | ! sinking (or floating) speeds without individual random motion. Code that 43 | ! calculates salinity and temperature at the particle location is included 44 | ! (but commented out) as a basis for calculating density-dependent sinking 45 | ! velocities. 46 | ! 47 | ! Tidal Stream Transport: Behavior = 7. 48 | ! 49 | ! 50 | ! Behavior algorithms and code created by: Elizabeth North 51 | ! Module structure created by: Zachary Schlag 52 | ! Created on: 2004 53 | ! Last Modified on: 22 March 2011 54 | ! ROMSPath Version: 1.0.1 55 | ! 56 | 57 | IMPLICIT NONE 58 | PRIVATE 59 | SAVE 60 | 61 | ! !Timer for C. ariakensis downward swimming behavior 62 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: timer 63 | 64 | ! !Behavior of each particle 65 | ! INTEGER, ALLOCATABLE, DIMENSION(:) :: P_behave 66 | 67 | 68 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(: ) :: & 69 | ! P_pediage, & !Age at which the particle will settle (become a pediveliger) 70 | ! P_deadage, & !Age at which the particle will stop moving (die) 71 | ! !The following are for calculating salt gradient: 72 | ! P_Sprev, & !Salinity at particle's previous location 73 | ! P_zprev !Particle's previous depth 74 | 75 | 76 | ! !Swimming speed (age-dependent, linear increase unless constant) 77 | ! !(n,1)slope, (n,2)intercept, (n,3) speed at current age 78 | ! DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: P_swim 79 | 80 | ! !For behavior 7, tracks if particle is on the bottom 81 | ! LOGICAL, ALLOCATABLE, DIMENSION(:) :: bottom 82 | 83 | ! !Tracks if the particle is dead (TRUE) or alive (FALSE) 84 | ! LOGICAL, ALLOCATABLE, DIMENSION(:) :: dead 85 | 86 | ! !Tracks if particles are Out Of Bounds (ie cross open ocean bound) 87 | ! LOGICAL, ALLOCATABLE, DIMENSION(:) :: oob 88 | 89 | !The following procedures have been made public: 90 | ! PUBLIC :: initBehave,updateStatus,behave,getStatus,finBehave, & 91 | ! setOut,isOut,die,isDead 92 | PUBLIC :: behave 93 | 94 | CONTAINS 95 | 96 | ! SUBROUTINE initBehave() !Initialize the behavior module 97 | ! USE PARAM_MOD, ONLY: numpar,Behavior,swimfast,swimslow,swimstart, & 98 | ! pediage,deadage,Sgradient,settlementon 99 | ! USE SETTLEMENT_MOD, ONLY: initSettlement 100 | ! USE NORM_MOD, ONLY: norm 101 | ! IMPLICIT NONE 102 | ! INTEGER :: n 103 | 104 | ! write(*,*) 'initialize behavior' 105 | 106 | ! !Allocate Behavior Variables 107 | ! ALLOCATE(timer(numpar)) 108 | ! ALLOCATE(P_behave(numpar)) 109 | ! ALLOCATE(P_pediage(numpar)) 110 | ! ALLOCATE(P_deadage(numpar)) 111 | ! ALLOCATE(P_Sprev(numpar)) 112 | ! ALLOCATE(P_zprev(numpar)) 113 | ! ALLOCATE(P_swim(numpar,3)) 114 | ! ALLOCATE(dead(numpar)) 115 | ! ALLOCATE(oob(numpar)) 116 | 117 | ! IF(Behavior == 7) THEN 118 | ! ALLOCATE(bottom(numpar)) 119 | ! bottom = .TRUE. 120 | ! ENDIF 121 | 122 | ! do n=1,numpar 123 | ! !Set behavior to the one specified in ROMSPath.inc 124 | ! P_behave(n) = Behavior !Behavior 125 | ! P_pediage(n) = pediage !age at which particle reaches maximum swimming 126 | ! !speed and can settle (becomes a pediveliger) (s) 127 | ! P_deadage(n) = deadage !age at which particle stops moving (dies) (s) 128 | ! !Note: the following code assigns different veliger and pediveliger 129 | ! ! stage durations 130 | ! !P_pediage(n) = (14. + norm()*0.5)*24.*3600. 131 | ! !P_deadage(n) = P_pediage(n) + (7. + norm()*0.5)*24.*3600. 132 | 133 | ! !Calculate slope and intercept for age-dependent linear swimming speed 134 | ! P_swim(n,1) = (swimfast - swimslow)/(P_pediage(n) - swimstart) !slope 135 | ! P_swim(n,2) = swimfast - P_swim(n,1)*P_pediage(n) !intercept 136 | ! P_swim(n,3) = 0.0 !swimming speed (m/s) 137 | ! !Note: P_swim(n,3) is updated at each time step in Subroutine behave 138 | ! enddo 139 | 140 | ! !The following variables are used by the C. virginica and C. ariakensis 141 | ! ! behavior routines 142 | ! timer = DBLE(0.0) !to count how long C. arikensis particles swim down 143 | 144 | ! ! Initialize salt storage matrices 145 | ! P_Sprev = 0.0 !Initialized to 0.0 146 | ! P_zprev = 0.0 !Initialized to 0.0 147 | 148 | ! ! Initialize dead to .FALSE. i.e. all particles are initially alive 149 | ! dead = .FALSE. 150 | 151 | ! ! Initialize out of bounds tracker to .FALSE. 152 | ! ! (i.e. all particles start in bounds) 153 | ! oob = .FALSE. 154 | 155 | ! !if Settlement is turned on then inform Settlement module of the age at 156 | ! ! which particle can settle (i.e., become pediveligers) 157 | ! if(settlementon)then 158 | ! CALL initSettlement(P_pediage) 159 | ! endif 160 | 161 | ! END SUBROUTINE initBehave 162 | 163 | 164 | ! SUBROUTINE updateStatus(P_age,n) !Update particle status 165 | ! USE SETTLEMENT_MOD, ONLY: isSettled 166 | ! USE PARAM_MOD, ONLY: settlementon,mortality 167 | ! IMPLICIT NONE 168 | 169 | ! INTEGER, INTENT(IN) :: n 170 | ! DOUBLE PRECISION, INTENT(IN) :: P_age 171 | 172 | ! Determine if particle dies from old age, if so kill it 173 | ! if ((P_age .GE. P_deadage(n)) .AND. mortality) then 174 | ! if(settlementon)then 175 | ! if(.NOT. isSettled(n)) call die(n) 176 | ! else 177 | ! call die(n) 178 | ! endif 179 | ! endif 180 | 181 | ! END SUBROUTINE updateStatus 182 | 183 | ! SUBROUTINE behave(Xpar,Ypar,Zpar,Pwc_zb,Pwc_zc,Pwc_zf,P_zb,P_zc,P_zf, & 184 | ! P_zetac,P_age,P_depth,P_U,P_V,P_angle,n,it,ex,ix, & 185 | ! daytime,p,bott,XBehav,YBehav,ZBehav) 186 | SUBROUTINE behave(Xpar,Ypar,Zpar,XBehav,YBehav,ZBehav,Psize,ex,ix,ng,behout) 187 | ! USE PARAM_MOD, ONLY: us,dt,idt,twistart,twiend,Em,pi,daylength,Kd,thresh, & 188 | ! Sgradient,swimfast,swimstart,sink,Hswimspeed, & 189 | ! Swimdepth 190 | USE PARAM_MOD, ONLY: g,rhof,rhop,nu,mu,vort_cr,vort_sat,b0pv,b1pv,b0wv, & 191 | b1w,acc_cr,acc_sat,b0pa,b0wa,b1pa,Behavior,swimfast, & 192 | idt,t_b,t_c,t_f,va_flag,Process_VA,Process_WA 193 | ! USE HYDRO_MOD, ONLY: WCTS_ITPI 194 | 195 | USE PDF_MOD, ONLY: norm,laplace 196 | USE RANDOM_MOD, ONLY: genrand_real3 197 | USE INT_MOD, ONLY: polintd,getInterp3d,getInterp2D 198 | IMPLICIT NONE 199 | 200 | ! DOUBLE PRECISION, INTENT(IN) :: daytime 201 | ! DOUBLE PRECISION, INTENT(IN) :: Xpar,Ypar,Zpar,Pwc_zb(:),Pwc_zc(:), & 202 | ! Pwc_zf(:),P_zb,P_zc,P_zf,P_zetac,P_age, & 203 | ! P_depth,P_U,P_V,P_angle,ex(3),ix(3) 204 | DOUBLE PRECISION, INTENT(IN) :: Xpar,Ypar,Zpar,Psize,ex(3),ix(3) 205 | INTEGER, INTENT(IN) :: ng 206 | ! LOGICAL, INTENT(OUT) :: bott 207 | DOUBLE PRECISION, INTENT(OUT) :: XBehav,YBehav,ZBehav,behout(4) 208 | 209 | ! INTEGER :: btest,i,deplvl 210 | ! DOUBLE PRECISION :: negpos,dev1,devB,switch,switchslope 211 | ! DOUBLE PRECISION :: P_S,parBehav,Sslope,deltaS,deltaz 212 | ! ! DOUBLE PRECISION :: P_T !not needed unless temperature code below is enabled 213 | ! DOUBLE PRECISION :: dtime,tst,E0,P_light 214 | ! DOUBLE PRECISION :: currentspeed,Hdistance,theta,X,Y 215 | 216 | 217 | DOUBLE PRECISION :: lap1,accturbu,accwaveu,accturbv,accwavev,acctot,c1v,c2v,c1a,c2a 218 | DOUBLE PRECISION :: stdaccturbu,stdaccturbv,stdaccturbw,stdaccwaveu,stdaccwavev,stdaccwavew 219 | DOUBLE PRECISION :: stdvortturb,vortturbu,vortturbv,vortturbw,vorttot 220 | DOUBLE PRECISION :: pswimv,pswima,pswim,wswimv,wswima,wswim,r,wb,wsink 221 | DOUBLE PRECISION :: ey(3),zetab,zetac,zetaf,depth 222 | ! ***************** Initialize Return Values 223 | XBehav = 0.0 224 | YBehav = 0.0 225 | ZBehav = 0.0 226 | behout=0.0 227 | wb=0.0 228 | behout(1)=0.0 229 | behout(2)=0.0 230 | behout(3)=0.0 231 | behout(4)=0.0 232 | 233 | !********************************** 234 | !THIS IS WHERE WE PROCESS VORTICITY AND ACCELERATION 235 | !************************************* 236 | 237 | 238 | 239 | 240 | if ((process_VA) .OR. (Process_WA)) then 241 | 242 | depth = DBLE(-1.0)* getInterp2D("depth",ng,Xpar,Ypar,t_c) 243 | zetab = getInterp2D("zeta",ng,Xpar,Ypar,t_b) 244 | zetac = getInterp2D("zeta",ng,Xpar,Ypar,t_c) 245 | zetaf = getInterp2D("zeta",ng,Xpar,Ypar,t_f) 246 | 247 | 248 | 249 | if (Process_VA) then 250 | ey(1)=getInterp3d("turbaccel",ng,Xpar,Ypar,Zpar,t_b,2,zetab,depth) 251 | ey(2)=getInterp3d("turbaccel",ng,Xpar,Ypar,Zpar,t_c,2,zetac,depth) 252 | ey(3)=getInterp3d("turbaccel",ng,Xpar,Ypar,Zpar,t_f,2,zetaf,depth) 253 | stdaccturbu = polintd(ex,ey,3,ix(2)) 254 | ey(1)=getInterp3d("turbvort",ng,Xpar,Ypar,Zpar,t_b,2,zetab,depth) 255 | ey(2)=getInterp3d("turbvort",ng,Xpar,Ypar,Zpar,t_c,2,zetac,depth) 256 | ey(3)=getInterp3d("turbvort",ng,Xpar,Ypar,Zpar,t_f,2,zetaf,depth) 257 | stdvortturb = polintd(ex,ey,3,ix(2)) 258 | stdaccturbu=stdaccturbu*100.0D0 259 | stdvortturb=stdvortturb 260 | else 261 | stdaccturbu=0.0 262 | stdvortturb=0.0 263 | endif 264 | 265 | !PLACEHOLDER FOR STD ACCESS 266 | ! stdvortturb=1.8257 267 | 268 | ! stdaccturbu=1.2574 269 | if (Process_WA) then 270 | ey(1)=getInterp3d("waveaccelu",ng,Xpar,Ypar,Zpar,t_b,2,zetab,depth) 271 | ey(2)=getInterp3d("waveaccelu",ng,Xpar,Ypar,Zpar,t_c,2,zetac,depth) 272 | ey(3)=getInterp3d("waveaccelu",ng,Xpar,Ypar,Zpar,t_f,2,zetaf,depth) 273 | stdaccwaveu = polintd(ex,ey,3,ix(2)) 274 | ey(1)=getInterp3d("waveaccelv",ng,Xpar,Ypar,Zpar,t_b,2,zetab,depth) 275 | ey(2)=getInterp3d("waveaccelv",ng,Xpar,Ypar,Zpar,t_c,2,zetac,depth) 276 | ey(3)=getInterp3d("waveaccelv",ng,Xpar,Ypar,Zpar,t_f,2,zetaf,depth) 277 | stdaccwavev = polintd(ex,ey,3,ix(2)) 278 | stdaccwaveu=stdaccwaveu*100.0D0 279 | stdaccwavev=stdaccwavev*100.0D0 280 | else 281 | stdaccwaveu=0.0D0 282 | stdaccwavev=0.0D0 283 | endif 284 | 285 | lap1= laplace() 286 | vortturbu= stdvortturb*lap1 287 | 288 | lap1= laplace() 289 | vortturbv= stdvortturb*lap1 290 | 291 | ! lap1= laplace() 292 | ! vortturbw= stdvortturb*lap1 293 | 294 | vorttot=sqrt(((vortturbu)**2.0D0)+((vortturbv)**2.0D0)) 295 | 296 | !vorttot=sqrt(((vortturbu)**2.0D0)+((vortturbv)**2.0D0)+((vortturbw)**2.0D0)) 297 | 298 | lap1= laplace() 299 | accturbu= stdaccturbu*lap1 300 | 301 | lap1= laplace() 302 | accturbv= stdaccturbu*lap1 303 | 304 | !lap1= laplace() 305 | !accturbw= stdaccturbw*lap1 306 | 307 | lap1= norm() 308 | accwaveu= stdaccwaveu*lap1 309 | 310 | lap1= norm() 311 | accwavev=stdaccwavev*lap1 312 | 313 | !lap1= norm() 314 | !accwavew= stdaccwavw*lap1 315 | 316 | acctot=sqrt(((accturbu+accwaveu)**2.0D0)+((accturbv+accwavev)**2.0D0)) 317 | 318 | 319 | !acctot=sqrt(((accturbu+accwaveu)**2.0D0)+((accturbv+accwavev)**2.0D0)+((accturbw+accwavew)**2.0D0)) 320 | 321 | 322 | c1v = 2.0D0/log(vort_cr/vort_sat); 323 | c2v = c1v*log(vorttot/((vort_cr*vort_sat)**0.5D0)); 324 | 325 | 326 | c1a = 2.0D0/log(acc_cr/acc_sat); 327 | c2a = c1a*log(acctot/((acc_cr*acc_sat)**0.5D0)); 328 | 329 | pswimv=(b1pv-b0pv)/(1.0D0+exp(-2.0D0*c2v))+b0pv; 330 | pswima=(b1pa-b0pa)/(1.0D0+exp(-2.0D0*c2a))+b0pa; 331 | 332 | 333 | if (va_flag.eq.1) then 334 | pswim=pswimv; 335 | elseif (va_flag.eq.2) then 336 | pswim=pswima; 337 | else 338 | pswim=min(pswima,pswimv); 339 | endif 340 | !swim speed for vorticity response 341 | wswimv=((b1w-b0wv)*1.0D0/(1.0D0+exp(-2.0D0*c2v)))+b0wv; 342 | 343 | !swim speed for acceleration response 344 | wswima=((b1w-b0wa)*1.0D0/(1.0D0+exp(-2.0D0*c2a)))+b0wa; 345 | 346 | ! actual swim velocity determined by maximum response 347 | 348 | if (va_flag.eq.1) then 349 | wswim=wswimv; 350 | elseif (va_flag.eq.2) then 351 | wswim=wswima; 352 | else 353 | 354 | ! wswim=max(wswima,wswimv); ! swimming velocity (cm s^-1) 355 | wswim=wswima+wswimv; ! Changed to sum as per HFUCHS, 1/27/2019. 356 | 357 | endif 358 | 359 | r=Psize/2.0D4 360 | wsink=((3.0D0*mu)-sqrt((4.0D0/3.0D0)*g*(r**3.0D0)*rhof*(rhop-rhof)+(9.0D0*( mu**2.0D0))))/(r*rhof); 361 | 362 | behout(1)=acctot/100.0D0 363 | behout(2)=vorttot 364 | 365 | 366 | lap1 = genrand_real3() 367 | if (lap1.lt.pswim) then 368 | wb=wswim 369 | behout(4)=0.0 370 | else 371 | wb=wsink 372 | behout(4)=1.0 373 | endif 374 | 375 | behout(3)=wb 376 | 377 | 378 | endif 379 | 380 | !UPDATE Z DISPLACEMENT 381 | if(Behavior .EQ. 1) then 382 | 383 | ZBehav=swimfast*DBLE(idt) 384 | 385 | elseif ((Behavior.EQ.10)) then 386 | 387 | ZBehav=wb*dble(idt)/100.0D0 388 | 389 | else 390 | XBehav = 0.0 391 | YBehav = 0.0 392 | ZBehav = 0.0 393 | endif 394 | 395 | 396 | ! ***************** Update vertical swimming speeds based on particle age 397 | 398 | ! if(P_age .GE. swimstart) P_swim(n,3) = P_swim(n,1)*P_age+P_swim(n,2) 399 | ! if(P_age .GE. P_pediage(n)) P_swim(n,3) = swimfast 400 | 401 | ! ! ***************** Prepare for TYPE 4 & 5 (Oyster Larvae) Behaviors 402 | 403 | ! !Update pediveliger behavior/status and timer 404 | ! IF(P_behave(n) .EQ. 4 .OR. P_behave(n) .EQ. 5) THEN 405 | 406 | ! !Set behavior code for pediveligers 407 | ! if (P_age .GE. P_pediage(n) .AND. P_age .LT. P_deadage(n)) then 408 | ! P_behave(n) = 2 409 | ! endif 410 | 411 | ! !decrement timer 412 | ! timer(n) = max(DBLE(0.0), timer(n)-DBLE(dt)) 413 | ! ENDIF 414 | 415 | ! !obtain salinity at particle location (P_S) to cue oyster larvae or tidal 416 | ! ! stream transport behavior 417 | ! IF ((P_behave(n).EQ.4) .OR. (P_behave(n).EQ.5 .AND. timer(n).EQ.0.0) .OR. & 418 | ! P_behave(n).EQ.7) THEN 419 | 420 | ! do i=3,us-2 421 | ! if ((Zpar .LT. Pwc_zb(i)) .OR. (Zpar .LT. Pwc_zc(i)) .OR. & 422 | ! (Zpar .LT. Pwc_zf(i))) exit 423 | ! enddo 424 | ! deplvl = i-2 !depth level 425 | 426 | ! !Salinity at particle location 427 | ! P_S = WCTS_ITPI("salt",Xpar,Ypar,deplvl,Pwc_zb,Pwc_zc,Pwc_zf,us,P_zb, & 428 | ! P_zc,P_zf,ex,ix,p,4) 429 | 430 | ! ENDIF 431 | 432 | 433 | ! ! ********************************************************* 434 | ! ! * * 435 | ! ! * Behaviors * 436 | ! ! * * 437 | ! ! ********************************************************* 438 | 439 | ! parBehav = 0.0 440 | 441 | ! !TYPE 1. Surface oriented. Particle swims up if deeper than 1 m. 442 | ! IF (P_behave(n).EQ.1) THEN 443 | ! btest = 0 !switch to control behavior 444 | 445 | ! !particle has 80% chance of swimming up if deeper than 1.0 m of bottom 446 | ! if (P_zc .LT. (P_zetac-1.0)) then 447 | ! negpos = 1.0 448 | ! dev1=genrand_real1() 449 | ! switch = 0.80 450 | ! if (dev1.GT.switch) negpos = -1.0 451 | ! devB=genrand_real1() 452 | ! parBehav=negpos*devB*P_swim(n,3) 453 | ! btest = 1 454 | ! end if 455 | 456 | ! !if within 1 m of surface, swim randomly (50% chance of swimming up) 457 | ! if (btest.EQ.0) then 458 | ! negpos = 1.0 459 | ! dev1=genrand_real1() 460 | ! switch = 0.5 461 | ! if (dev1.GT.switch) negpos = -1.0 462 | ! devB=genrand_real1() 463 | ! parBehav=negpos*devB*P_swim(n,3) 464 | ! end if 465 | 466 | ! END IF 467 | 468 | 469 | ! !TYPE 2. Near-bottom. Particle swim down if not within 1 m of bottom. 470 | ! IF (P_behave(n).EQ.2 .OR. (P_behave(n).EQ.5 .AND. timer(n).GT.0.0)) THEN 471 | ! btest = 0 !switch to control behavior 472 | 473 | ! !particle has 80% change of swimming down if greater than 1.0 m 474 | ! ! from bottom 475 | ! if (P_zc .GT. (P_depth+1.0)) then 476 | ! negpos = 1.0 477 | ! dev1=genrand_real1() 478 | ! switch = 0.20 479 | ! if (dev1.GT.switch) negpos = -1.0 480 | ! devB=genrand_real1() 481 | ! parBehav=negpos*devB*P_swim(n,3) 482 | ! btest = 1 483 | ! end if 484 | 485 | ! !if within 1 m of bottom, just swim randomly 486 | ! if (btest.EQ.0) then 487 | ! negpos = 1.0 488 | ! dev1=genrand_real1() 489 | ! switch = 0.5 490 | ! if (dev1.GT.switch) negpos = -1.0 491 | ! devB=genrand_real1() 492 | ! parBehav=negpos*devB*P_swim(n,3) 493 | ! end if 494 | 495 | ! END IF 496 | 497 | ! !TYPE 3: Diurnal Vertical Migration 498 | ! IF (P_behave(n).EQ.3) THEN 499 | 500 | ! !A. Find daytime in hrs since midnight (dtime) 501 | ! dtime = (daytime - aint(daytime))*DBLE(24.0) !time of day 502 | ! !This assumes that model simulations start at midnight 503 | 504 | ! !B. Calcluate irradiance at the water's surface (E0) 505 | ! tst = 0.0 !seconds since twilight start 506 | ! E0 = 0.0 !irradiance at the water's surface 507 | ! if (dtime.GT.twiStart .AND. dtime.LT.twiEnd) then 508 | ! tst=(dtime-twiStart)*DBLE(3600.0) 509 | ! E0= Em*SIN(PI*tst/(daylength*DBLE(3600.0)))* & 510 | ! SIN(PI*tst/(daylength*DBLE(3600.0))) 511 | ! else 512 | ! E0 = 0.0 513 | ! end if 514 | 515 | ! !C. Calcluate irradiance at depth of the particle 516 | ! P_light = E0 * exp(Kd*P_zc) 517 | 518 | ! !If light at particle location is less than threshold, random swimming 519 | ! if (P_light.LT.thresh ) then 520 | ! negpos = 1.0 521 | ! dev1=genrand_real1() 522 | ! switch = 0.5 523 | ! if (dev1.GT.switch) negpos = -1.0 524 | ! devB=genrand_real1() 525 | ! parBehav=negpos*devB*P_swim(n,3) 526 | ! end if 527 | ! !If light at particle > threshold, then have 80% chance of swimming down 528 | ! if (P_light.GT.thresh ) then 529 | ! negpos = 1.0 530 | ! dev1=genrand_real1() 531 | ! switch = 0.20 532 | ! if (dev1.GT.switch) negpos = -1.0 533 | ! devB=genrand_real1() 534 | ! parBehav=negpos*devB*P_swim(n,3) 535 | ! end if 536 | 537 | ! END IF 538 | 539 | 540 | ! !TYPE 4. Crassostrea virginica -- above the halocline 541 | ! IF (P_behave(n).EQ.4) THEN 542 | ! if (it.EQ.1) then 543 | ! P_Sprev(n) = P_S !for first iteration 544 | ! P_zprev(n) = P_zc 545 | ! endif 546 | ! btest = 0 !switch to control behavior 547 | ! Sslope = 0.0 !salinity gradient that larvae swam through 548 | 549 | ! !determine if larva swam through salinity gradient large enough to 550 | ! ! cue behavior; if so, then 80% chance of swimming up 551 | ! deltaS = P_Sprev(n) - P_S 552 | ! deltaz = P_zprev(n) - P_zc 553 | ! if (it.GT.1) Sslope = deltaS/deltaz 554 | ! if (abs(Sslope).GT.Sgradient) then 555 | ! negpos = 1.0 556 | ! dev1=genrand_real1() 557 | ! switch = 0.80 558 | ! if (dev1.GT.switch) negpos = -1.0 559 | ! parBehav=negpos*P_swim(n,3) 560 | ! btest = 1 561 | ! endif 562 | 563 | ! !if no directed swimming, swim randomly with probabilities that result 564 | ! ! in particles moving up initially, then slowly moving toward bottom 565 | ! ! with increasing age 566 | ! if (btest.EQ.0) then 567 | ! negpos = 1.0 568 | ! dev1=genrand_real1() 569 | ! if (P_age .LT. 1.5*24.*3600.) then !if Age < 1.5 Days 570 | ! switch = 0.1 571 | ! elseif (P_age .LT. 5.*24.*3600.) then !if 1.5 Days <= Age < 5.0 Days 572 | ! switch = 0.49 573 | ! elseif (P_age .LT. 8.*24.*3600.) then !if 5.0 Days <= Age < 8.0 Days 574 | ! switch = 0.50 575 | ! else !if Age >= 8.0 Days 576 | ! switchslope = (DBLE(0.50)-DBLE(0.517)) / & 577 | ! (DBLE(8.0)*DBLE(24.0)*DBLE(3600.0) - P_pediage(n)) 578 | ! switch = switchslope*P_age + DBLE(0.50) - & 579 | ! switchslope*DBLE(8.0)*DBLE(24.0)*DBLE(3600.0) 580 | ! if (P_zc .LT. P_depth+1.) switch = 0.5 581 | ! endif 582 | ! if (dev1.GT.(1-switch)) negpos = -1.0 583 | ! devB=genrand_real1() 584 | ! parBehav=negpos*devB*P_swim(n,3) 585 | ! endif 586 | 587 | ! !update previous salt and depth matrix for next iteration 588 | ! P_Sprev(n) = P_S 589 | ! P_zprev(n) = P_zc 590 | ! ENDIF 591 | 592 | 593 | ! !TYPE 5. Crassostrea ariakensis -- below the halocline 594 | ! IF (P_behave(n).EQ.5 .AND. timer(n).EQ.0.0) THEN 595 | ! if (it.EQ.1) then 596 | ! P_Sprev(n) = P_S !for first iteration 597 | ! P_zprev(n) = P_zc 598 | ! endif 599 | ! btest = 0 !switch to control behavior 600 | ! Sslope = 0.0 !salinity gradient that larvae swam through 601 | 602 | ! !determine if larva swam through salinity gradient large enough to 603 | ! ! cue behavior. If so, then 80% chance of swimming down. Set timer 604 | ! ! to keep particle near bottom for 2 hrs 605 | ! deltaS = P_Sprev(n) - P_S 606 | ! deltaz = P_zprev(n) - P_zc 607 | ! if (it.GT.1) Sslope = deltaS/deltaz 608 | ! if (abs(Sslope).GT.Sgradient) then 609 | ! negpos = 1.0 610 | ! dev1=genrand_real1() 611 | ! switch = 0.20 612 | ! btest = 1 613 | ! timer(n) = DBLE(2.0)*DBLE(3600.0) !2 hr times 3600 s 614 | ! if (dev1.GT.switch) negpos = -1.0 615 | ! parBehav=negpos*P_swim(n,3) 616 | ! !keep bottom oriented behavior from starting until after particle 617 | ! ! is 3.5 days old 618 | ! if (P_age .LT. 3.5*24.*3600.) then 619 | ! btest = 0 620 | ! timer(n) = 0. 621 | ! endif 622 | ! endif 623 | 624 | ! !if no directed swimming, just swim randomly with probabilities that 625 | ! ! result in particles moving up initially, then moving toward bottom 626 | ! ! with increasing age 627 | ! if (btest.EQ.0) then 628 | ! negpos = 1.0 629 | ! dev1=genrand_real1() 630 | ! switch = 0.495 631 | ! if (P_age .LT. 1.5*24.*3600.) switch = 0.9 632 | ! if (P_age .GT. 2.0*24.*3600. .AND. P_age .LT. 3.5*24.*3600.) then 633 | ! switchslope = (DBLE(0.3)-DBLE(0.495)) / & 634 | ! (DBLE(2.0)*DBLE(24.0)*DBLE(3600.0) - & 635 | ! DBLE(3.5)*DBLE(24.0)*DBLE(3600.0)) 636 | ! switch = switchslope*P_age+DBLE(0.3) - & 637 | ! switchslope*DBLE(2.0)*DBLE(24.0)*DBLE(3600.0) 638 | ! endif 639 | ! if (dev1.GT.switch) negpos = -1.0 640 | ! devB=genrand_real1() 641 | ! parBehav=negpos*devB*P_swim(n,3) 642 | ! endif 643 | 644 | ! !update previous salt and depth matrix for next iteration 645 | ! P_Sprev(n) = P_S 646 | ! P_zprev(n) = P_zc 647 | ! ENDIF 648 | 649 | ! !TYPE 6. Constant -- no random motion to vertical movement 650 | ! IF ((P_behave(n).EQ.6)) THEN 651 | ! if(P_age .GE. swimstart) then 652 | ! parBehav = sink 653 | ! else 654 | ! parBehav = P_swim(n,3) 655 | ! endif 656 | 657 | ! !Note: the code below is included if someone wants to calculate density 658 | ! ! ! To calculate salinity (P_S) and temperature (P_T) at particle location 659 | ! ! do i=3,us-2 660 | ! ! if ((Zpar .LT. Pwc_zb(i)) .OR. (Zpar .LT. Pwc_zc(i)) .OR. & 661 | ! ! (Zpar .LT. Pwc_zf(i))) exit 662 | ! ! enddo 663 | ! ! deplvl = i-2 !depth level 664 | ! ! 665 | ! ! !Salinity at particle location 666 | ! ! P_S = WCTS_ITPI("salt",Xpar,Ypar,deplvl,Pwc_zb,Pwc_zc,Pwc_zf,us, & 667 | ! ! P_zb,P_zc,P_zf,ex,ix,p,4) 668 | ! ! 669 | ! ! !Temperature at particle location 670 | ! ! P_T = WCTS_ITPI("temp",Xpar,Ypar,deplvl,Pwc_zb,Pwc_zc,Pwc_zf,us, & 671 | ! ! P_zb,P_zc,P_zf,ex,ix,p,4) 672 | ! ENDIF 673 | 674 | ! !Calculate movement due to behavior for all behaviors other than 7 675 | ! ZBehav = parBehav * idt 676 | 677 | ! !TYPE 7. Tidal Stream Transport: if flooding, then swim in direction of 678 | ! ! currents, else sit on bottom 679 | ! IF ((P_behave(n).EQ.7)) THEN 680 | ! ! Set initial values for the first iteration 681 | ! if (it.EQ.1) then 682 | ! P_Sprev(n) = P_S 683 | ! currentspeed = 0.0 684 | ! endif 685 | ! !Find current speed at the particle location ( c = sqrt(a**2 + b**2) ) 686 | ! currentspeed = sqrt( (P_U*cos(P_angle) - P_V*sin(P_angle))**2 + & 687 | ! (P_U*sin(P_angle) + P_V*cos(P_angle))**2 ) 688 | ! if (bottom(n) .EQV. .TRUE.) then !CRS 689 | ! !if particle is on bottom, test if salinity is increasing 690 | ! if (P_Sprev(n).LT.P_S) then !if salinity is increasing: 691 | ! bottom(n) = .FALSE. ! come off bottom 692 | ! ZBehav = P_depth + Swimdepth ! and swim to the swimming depth 693 | ! else 694 | ! ZBehav = -9999 !if salinity is not increasing, stay on bottom 695 | ! end if 696 | ! else 697 | ! !if particle is not on bottom, test if currents are not slack 698 | ! ! (defined as 0.05 m/s) 699 | ! if (currentspeed.GT.0.05) then 700 | ! !if the current speed is greater than 0.05 m/s, then swim in the 701 | ! ! direction of the current 702 | ! Hdistance = Hswimspeed*idt 703 | ! !find theta of currents 704 | ! theta = atan( (P_U*sin(P_angle) + P_V*cos(P_angle)) / & 705 | ! (P_U*cos(P_angle) - P_V*sin(P_angle)) ) 706 | ! X = (P_U*cos(P_angle) - P_V*sin(P_angle)) 707 | ! Y = (P_U*sin(P_angle) + P_V*cos(P_angle)) 708 | ! if(X.GT.0.0) then 709 | ! XBehav = Hdistance*cos(theta) 710 | ! YBehav = Hdistance*sin(theta) 711 | ! end if 712 | ! if(X.LT.0.0) then 713 | ! XBehav = DBLE(-1.0)*Hdistance*cos(theta) 714 | ! YBehav = DBLE(-1.0)*Hdistance*sin(theta) 715 | ! end if 716 | ! if(X.EQ.0 .AND. Y.GE.0.0) then 717 | ! XBehav = 0.0 718 | ! YBehav = Hdistance 719 | ! end if 720 | ! if(X.EQ.0 .AND. Y.LE.0.0) then 721 | ! XBehav = 0.0 722 | ! YBehav = DBLE(-1.0)*Hdistance 723 | ! end if 724 | ! !keep vertical position of particle at swim depth 725 | ! ZBehav = P_depth + Swimdepth 726 | ! else 727 | ! ZBehav = -9999 !if the current speed is less than 0.05 m/s, 728 | ! bottom(n) = .TRUE. ! then swim to bottom 729 | ! end if 730 | ! end if 731 | ! bott = bottom(n) 732 | ! ENDIF 733 | 734 | ! ******************* End Particle Behavior ****************************** 735 | END SUBROUTINE behave 736 | 737 | 738 | ! INTEGER FUNCTION getStatus(n) 739 | ! !This function returns an identification number that describes a particle's 740 | ! !behavior type or status for use in visualization routines. It was 741 | ! !initially developed to contain the color code for plotting in Surfer.) 742 | ! USE PARAM_MOD, ONLY: SETTLEMENTON,OPENOCEANBOUNDARY 743 | ! USE SETTLEMENT_MOD, ONLY: isSettled 744 | ! IMPLICIT NONE 745 | ! INTEGER, INTENT(IN) :: n 746 | 747 | ! getStatus = P_behave(n) ! Set Status to behavior ID 748 | ! ! Change if Dead, Settled, or OutOfBounds 749 | 750 | ! if(dead(n)) getStatus = -1 ! -1 = Dead 751 | ! if(settlementon)then 752 | ! if(isSettled(n)) getStatus = -2 ! -2 = Settled 753 | ! endif 754 | ! if(OpenOceanBoundary)then 755 | ! if(oob(n)) getStatus = -3 ! -3 = Out of Bounds 756 | ! endif 757 | 758 | ! END FUNCTION getStatus 759 | 760 | 761 | ! LOGICAL FUNCTION isDead(n) 762 | ! !This function returns .TRUE. if the particle is "dead", and FALSE if not 763 | ! IMPLICIT NONE 764 | ! INTEGER, INTENT(IN) :: n 765 | 766 | ! isDead = dead(n) 767 | 768 | ! END FUNCTION isDead 769 | 770 | 771 | ! SUBROUTINE die(n) 772 | ! !This subroutine sets the value of dead(n) to TRUE, indicating 773 | ! ! the particle is "dead" 774 | ! IMPLICIT NONE 775 | ! INTEGER, INTENT(IN) :: n 776 | 777 | ! dead(n) = .TRUE. 778 | 779 | ! END SUBROUTINE die 780 | 781 | 782 | ! SUBROUTINE setOut(n) 783 | ! !This subroutine changes particle n's status to out of bounds 784 | ! IMPLICIT NONE 785 | ! INTEGER, INTENT(IN) :: n 786 | 787 | ! oob(n) = .TRUE. 788 | 789 | ! END SUBROUTINE setOut 790 | 791 | ! LOGICAL FUNCTION isOut(n) 792 | ! !This function returns the value of oob for particle n 793 | ! ! i.e. Returns True if the particle is out of bounds, False if in bounds 794 | ! IMPLICIT NONE 795 | ! INTEGER, INTENT(IN) :: n 796 | 797 | ! isOut = oob(n) 798 | 799 | ! END FUNCTION isOut 800 | 801 | 802 | ! SUBROUTINE finBehave() !Finish the behavior module 803 | ! USE PARAM_MOD , ONLY: settlementon 804 | ! USE SETTLEMENT_MOD, ONLY: finSettlement 805 | ! IMPLICIT NONE 806 | 807 | ! !Deallocate Behavior Variables 808 | ! DEALLOCATE(timer) 809 | ! DEALLOCATE(P_behave) 810 | ! DEALLOCATE(P_pediage) 811 | ! DEALLOCATE(P_deadage) 812 | ! DEALLOCATE(P_Sprev) 813 | ! DEALLOCATE(P_zprev) 814 | ! DEALLOCATE(P_swim) 815 | ! DEALLOCATE(dead) 816 | ! DEALLOCATE(oob) 817 | 818 | ! if(ALLOCATED(bottom))DEALLOCATE(bottom) 819 | 820 | ! !If Settlement is on, Deallocate Settlement Variables 821 | ! if(settlementon) call finSettlement() 822 | 823 | ! END SUBROUTINE finBehave 824 | 825 | 826 | END MODULE BEHAVIOR_MOD 827 | --------------------------------------------------------------------------------